From b857abb01fa60639bf244ffdd5082987dae11529 Mon Sep 17 00:00:00 2001 From: Cezary Czaplewski Date: Wed, 28 Mar 2012 23:53:42 +0200 Subject: [PATCH] cleaning - unecessary files deleted tmscore has been added to CSA as alternative of angular difference reminimization is working in CSA version --- source/unres/src_CSA/COMMON.CSA | 4 +- source/unres/src_CSA/Makefile | 9 +- source/unres/src_CSA/bank.F | 315 +++- source/unres/src_CSA/dfa.F.not_gly | 3188 ----------------------------------- source/unres/src_CSA/dfa.F.org | 3100 ---------------------------------- source/unres/src_CSA/dfa__.F | 3123 ---------------------------------- source/unres/src_CSA/diff12.f | 57 +- source/unres/src_CSA/initialize_p.F | 4 +- source/unres/src_CSA/minim_jlee.F | 6 + source/unres/src_CSA/readrtns_csa.F | 3 + source/unres/src_CSA/rmsd.F | 44 + source/unres/src_CSA/together.F | 64 +- source/unres/src_CSA/unres_csa.F | 245 ++- 13 files changed, 707 insertions(+), 9455 deletions(-) delete mode 100644 source/unres/src_CSA/dfa.F.not_gly delete mode 100644 source/unres/src_CSA/dfa.F.org delete mode 100644 source/unres/src_CSA/dfa__.F diff --git a/source/unres/src_CSA/COMMON.CSA b/source/unres/src_CSA/COMMON.CSA index b503065..9c117c0 100644 --- a/source/unres/src_CSA/COMMON.CSA +++ b/source/unres/src_CSA/COMMON.CSA @@ -5,7 +5,7 @@ & n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, & is1,is2,nseed,ntotal,icmax,nstmax,irestart,nran0,nran1,irr, & nglob_csa,nmin_csa,ndiff,nbankm,iucut - logical ldih_bias - common/dih_control/rdih_bias,ldih_bias + logical ldih_bias,tm_score + common/dih_control/rdih_bias,ldih_bias,tm_score common/diffcuta/ diffcut diff --git a/source/unres/src_CSA/Makefile b/source/unres/src_CSA/Makefile index 54502d9..e0a56b6 100644 --- a/source/unres/src_CSA/Makefile +++ b/source/unres/src_CSA/Makefile @@ -5,12 +5,13 @@ CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ # -DPROCOR # -DTSCSC #-DTIMING \ +# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC # -DMOMENT #-DPARVEC #-DPARINT -DPARINTDER -INSTALL_DIR = /usr/local/mpich-1.2.7p1-intel -#INSTALL_DIR =/users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ +#INSTALL_DIR = /usr/local/mpich-1.2.7p1-intel +INSTALL_DIR =/users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ FC= ifort @@ -23,7 +24,7 @@ FFLAGS3 = -c -w -O3 -mp FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include -BIN = ../bin/unres_Tc_procor_050711_dfa_csa_4P_800.exe +BIN = ../bin/unres_Tc_procor_030512_dfa_csa_4P_tmscore.exe LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich ARCH = LINUX @@ -49,7 +50,7 @@ object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ indexx.o prng_32.o contact.o gen_rand_conf.o \ sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ - distfit.o banach.o + distfit.o banach.o TMscore_subroutine.o minim_mult.o unres: ${object} # cc -o compinfo compinfo.c diff --git a/source/unres/src_CSA/bank.F b/source/unres/src_CSA/bank.F index 980c8d2..38723ba 100644 --- a/source/unres/src_CSA/bank.F +++ b/source/unres/src_CSA/bank.F @@ -136,34 +136,7 @@ cccccccccccccccccccccccccccccccccccccccccccc endif enddo c end of loop over all newly obtained conformations - do i=0,mxmv - if(nstatnx(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - endif - else - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - endif - endif - enddo - call flush(iout) + call print_mv_stat crc Update dij crc moved up, saves some get_diff12 calls crc @@ -1052,6 +1025,88 @@ c--------------------------------- return end c--------------------------------- + subroutine get_diff_p + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'mpif.h' + integer ij(mxio*mxio/2,2) + double precision dij_local(mxio,mxio) + +c write (iout,*) 'Processor ',me,' broadcasting' + call mpi_bcast(nbank,1,mpi_integer,0,CG_COMM,ierr) + call mpi_bcast(numch,1,mpi_integer,0,CG_COMM,ierr) + call mpi_bcast(bvar,mxang*maxres*mxch*nbank, + & mpi_double_precision,0,CG_COMM,ierr) + call mpi_bcast(jbank,nbank,mpi_integer,0,CG_COMM,ierr) +c write (iout,*) 'Processor ',me,' after broadcasting' +c call flush(iout) + + k=0 + do i1=1,nbank-1 + do i2=i1+1,nbank + k=k+1 + ij(k,1)=i1 + ij(k,2)=i2 + dij_local(i1,i2)=0.0 + dij_local(i2,i1)=0.0 + if(jbank(i1).eq.0.or.jbank(i2).eq.0) then + dij(i1,i2)=0.0 + dij(i2,i1)=0.0 + else + if(me.eq.king) then + dij_local(i1,i2)=dij(i1,i2) + dij_local(i2,i1)=dij(i2,i1) + endif + endif + enddo + dij(i1,i1)=0.0 + dij_local(i1,i1)=0.0 + enddo + + do i12=me+1,nbank*(nbank-1)/2,nodes + i1=ij(i12,1) + i2=ij(i12,2) + if(jbank(i1).eq.0.or.jbank(i2).eq.0) then + call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) + dij_local(i1,i2)=diff + dij_local(i2,i1)=diff + endif + enddo + + call mpi_reduce(dij_local,dij,mxio*nbank, + & mpi_double_precision,mpi_sum,0,CG_COMM,ierr) + + + if (me.eq.king) then + + tdiff=0.d0 + difmin=9.d190 + do i1=1,nbank-1 + do i2=i1+1,nbank +cd write (iout,*) "!!!ppp",i1,i2,dij(i1,i2) +cd call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) +cd write (iout,*) "!!!",i1,i2,diff + tdiff=tdiff+dij(i1,i2) + if(diff.lt.difmin) difmin=diff + enddo + enddo + + do i=1,nbank + jbank(i)=1 + enddo + + avedif=tdiff/nbank/(nbank-1)*2 + + endif + + return + end + +c--------------------------------- subroutine estimate_cutdif(adif,xct,cutdifr) implicit real*8 (a-h,o-z) include 'DIMENSIONS' @@ -1090,3 +1145,207 @@ c--------------------------------- return end +c----------------------------------------- + subroutine refresh_bank_master_tmscore(ifrom,econf,n) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + include 'mpif.h' + character chacc + integer iaccn + double precision l_diff(mxio),denep + integer info(12),idmin + +cd write(iout,*) 'refresh_bank_master_tmscore',ifrom +cd flush(iout) + + info(1)=0 + info(2)=-2 + call mpi_send(info,12,mpi_integer,ifrom,idint,CG_COMM, + * ierr) + call mpi_send(bvar,mxang*maxres*mxch*nbank,mpi_double_precision, + * ifrom,idreal,CG_COMM,ierr) + call mpi_recv(idmin,1,mpi_integer, + * ifrom,idint,CG_COMM,muster,ierr) + call mpi_recv(l_diff,nbank,mpi_double_precision, + * ifrom,idreal,CG_COMM,muster,ierr) + + chacc=' ' + iaccn=0 + nstatnx(movernx(n),1)=nstatnx(movernx(n),1)+1 + + difmin=l_diff(idmin) + if(difmin.lt.cutdif) then +c n is redundant to idmin + if(econf.lt.bene(idmin)) then + if(econf.lt.bene(idmin)-0.01d0) then + ibank(idmin)=0 + jbank(idmin)=0 + endif + denep=bene(idmin)-econf + call replace_bvar(idmin,n) +crc Update dij + do i1=1,nbank + if (i1.ne.idmin) then + dij(i1,idmin)=l_diff(i1) + dij(idmin,i1)=l_diff(i1) + endif + enddo + chacc='c' + iaccn=idmin + nstatnx(movernx(n),2)=nstatnx(movernx(n),2)+1 + if(idmin.eq.ibmax) call find_max + endif + else +c got new conformation + del_ene=0.0d0 + if(ebmax-ebmin.gt.del_ene) then + denep=ebmax-econf + call replace_bvar(ibmax,n) +crc Update dij + do i1=1,nbank + if (i1.ne.ibmax) then + dij(i1,ibmax)=l_diff(i1) + dij(ibmax,i1)=l_diff(i1) + endif + enddo + chacc='f' + iaccn=ibmax + nstatnx(movernx(n),3)=nstatnx(movernx(n),3)+1 + ibank(ibmax)=0 + jbank(ibmax)=0 + call find_max + else + call replace_bvar(ibmax,n) + ibank(ibmax)=0 + jbank(ibmax)=0 + call find_max + endif + endif +cccccccccccccccccccccccccccccccccccccccccccc + if (iaccn.eq.0) then + if (iref.eq.0) then + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5)') + & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',econf,' mv ', + & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9) + else + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5 + & ,a5,0pf4.1,a5,f3.0)') + & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',econf,' mv ', + & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), + & ' rms ',rmsn(n),' %NC ',pncn(n)*100 + endif + else + if (iref.eq.0) then + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5, + & 1x,a1,i4,0pf8.2,0pf9.1)') + & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',econf,' mv ', + & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), + & chacc,iaccn,difmin,denep + else + write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5, + & 0pf4.1,a5,f3.0,1x,a1,i4,0pf8.2,0pf9.1)') + & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',econf,' mv ', + & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), + & ' rms ',rmsn(n),' %NC ',pncn(n)*100, + & chacc,iaccn,difmin,denep + endif + endif + + do i=1,nbank + jbank(i)=1 + enddo + + return + end +c----------------------------------------- + subroutine refresh_bank_worker_tmscore(var) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.BANK' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'mpif.h' + integer muster(mpi_status_size) + double precision var(maxvar) + double precision dihang_l(mxang,maxres,mxch) + double precision l_diff(mxio) + + call mpi_recv(bvar,mxang*maxres*mxch*nbank,mpi_double_precision, + * 0,idreal,CG_COMM,muster,ierr) + + call var_to_geom(nvar,var) + do j=2,nres-1 + dihang_l(1,j,1)=theta(j+1) + dihang_l(2,j,1)=phi(j+2) + dihang_l(3,j,1)=alph(j) + dihang_l(4,j,1)=omeg(j) + enddo + + difmin=9.d9 + do m=1,nbank + call get_diff12(dihang_l,bvar(1,1,1,m),l_diff(m)) + if(l_diff(m).lt.difmin) then + difmin=l_diff(m) + idmin=m + endif + enddo + + tm_score=.false. + call get_diff12(dihang_l,bvar(1,1,1,idmin),a_diff) + tm_score=.true. + +cd write(iout,*) idmin,l_diff(idmin),a_diff + call mpi_send(idmin,1,mpi_integer,0,idint,CG_COMM, + * ierr) + call mpi_send(l_diff,nbank,mpi_double_precision, + * 0,idreal,CG_COMM,ierr) + + return + end +c------------------------------------------------ + subroutine print_mv_stat + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + + do i=0,mxmv + if(nstatnx(i,1).ne.0) then + if (i.le.9) then + write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') + & '## N',i,' total=',nstatnx(i,1), + & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), + & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) + else + write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') + & '##N',i,' total=',nstatnx(i,1), + & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), + & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) + endif + else + if (i.le.9) then + write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') + & '## N',i,' total=',nstatnx(i,1), + & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), + & ' %acc',0.0 + else + write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') + & '##N',i,' total=',nstatnx(i,1), + & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), + & ' %acc',0.0 + endif + endif + enddo + call flush(iout) + return + end diff --git a/source/unres/src_CSA/dfa.F.not_gly b/source/unres/src_CSA/dfa.F.not_gly deleted file mode 100644 index ed4d9b2..0000000 --- a/source/unres/src_CSA/dfa.F.not_gly +++ /dev/null @@ -1,3188 +0,0 @@ - subroutine init_dfa_vars - - include 'DIMENSIONS' - include 'COMMON.DFA' - - integer ii - -C Number of restraints - idisnum = 0 - iphinum = 0 - ithenum = 0 - ineinum = 0 - - idislis = 0 - iphilis = 0 - ithelis = 0 - ineilis = 0 - jneilis = 0 - jneinum = 0 - kshell = 0 - fnei = 0 -C For beta - nca = 0 - icaidx = 0 - -C real variables -CC WEIGHTS for each min - sccdist = 0.0d0 - fdist = 0.0d0 - sccphi = 0.0d0 - sccthe = 0.0d0 - sccnei = 0.0d0 - fphi1 = 0.0d0 - fphi2 = 0.0d0 - fthe1 = 0.0d0 - fthe2 = 0.0d0 -C energies - edfatot = 0.0d0 - edfadis = 0.0d0 - edfaphi = 0.0d0 - edfathe = 0.0d0 - edfanei = 0.0d0 - edfabet = 0.0d0 -C gradients - gdfad = 0.0d0 - gdfat = 0.0d0 - gdfan = 0.0d0 - gdfab = 0.0d0 -C weights for each E term -C these should be identical with - dis_inc = 0.0d0 - phi_inc = 0.0d0 - the_inc = 0.0d0 - nei_inc = 0.0d0 - beta_inc = 0.0d0 - wshet = 0.0d0 -C precalculate exp table! - dfaexp = 0.0d0 - do ii = 1, 15001 - dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) - end do - - return - end - - - subroutine read_dfa_info -C -C read fragment informations -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DFA' - - -C NOTE THAT FILENAMES are FIXED, CURRENTLY!! -C THIS SHOULD BE MODIFIED!! - - character*320 buffer - integer iodfa - parameter(iodfa=89) - - integer i, j, nval - integer ica1, ica2,ica3,ica4,ica5 - integer ishell, inca, itmp,iitmp - double precision wtmp -C -C READ DISTANCE -C - open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) - goto 34 - 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 34 continue - write(iout,'(a)') 'dist_dfa.dat is opened!' -C read title - read(iodfa, '(a)') buffer -C read number of restraints - read(iodfa, '(i)') IDFADIS - read(iodfa, *) dis_inc - do i=1, idfadis - read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval - - idisnum(i)=nval - idislis(1,i)=ica1 - idislis(2,i)=ica2 - - do j=1, nval - read(iodfa,*) tmp - fdist(i,j) = tmp - enddo - - do j=1, nval - read(iodfa,*) tmp - sccdist(i,j) = tmp - enddo - - enddo - close(iodfa) - write(iout,'(a)') 'dist_dfa.dat is closed!' - -C READ ANGLE RESTRAINTS -C PHI RESTRAINTS - open(iodfa, file='phi_dfa.dat',status='old',err=35) - goto 36 - 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - - 36 continue - write(iout,'(a)') 'phi_dfa.dat is opened!' - -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFAPHI - read(iodfa,*) phi_inc - do i=1, idfaphi - read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - iphinum(i)=nval - - iphilis(1,i)=ica1 - iphilis(2,i)=ica2 - iphilis(3,i)=ica3 - iphilis(4,i)=ica4 - iphilis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fphi1(i,j) = tmp1 - fphi2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccphi(i,j) = tmp - enddo - - enddo - close(iodfa) - -C THETA RESTRAINTS - open(iodfa, file='theta_dfa.dat',status='old',err=41) - goto 42 - 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 42 continue - write(iout,'(a)') 'theta_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFATHE - read(iodfa,*) the_inc - - do i=1, idfathe - read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - ithenum(i)=nval - - ithelis(1,i)=ica1 - ithelis(2,i)=ica2 - ithelis(3,i)=ica3 - ithelis(4,i)=ica4 - ithelis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fthe1(i,j) = tmp1 - fthe2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccthe(i,j) = tmp - enddo - - enddo - close(iodfa) -C END of READING ANGLE RESTRAINT! - -C NUMBER OF NEIGHBOR CAs - open(iodfa,file='nei_dfa.dat',status='old',err=37) - goto 38 - 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' - stop - 38 continue - write(iout,'(a)') 'nei_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') idfanei - read(iodfa,*) nei_inc - - do i=1, idfanei - read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval - - ineilis(i)=ica1 - kshell(i)=ishell - ineinum(i)=nval - - do j=1, nval - read(iodfa,*) inca - fnei(i,j) = inca -C write(*,*) 'READ NEI:',i,j,fnei(i,j) - enddo - - do j=1, nval - read(iodfa,*) tmp - sccnei(i,j) = tmp - enddo - - enddo - close(iodfa) -C END OF NEIGHBORING CA - -C READ BETA RESTRAINT - open(iodfa, file='beta_dfa.dat',status='old',err=39) - goto 40 - 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' - stop - 40 continue - write(iout,'(a)') 'beta_dfa.dat is opened!' - - read(iodfa,'(a)') buffer - read(iodfa,'(i)') itmp - read(iodfa,*) beta_inc - - do i=1,itmp - read(iodfa,*) ica1, iitmp - do j=1,itmp - read(iodfa,*) wtmp - wshet(i,j) = wtmp -c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) - enddo - enddo - - close(iodfa) -C END OF BETA RESTRAINT - - return - END - - subroutine edfad(edfadis) - - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - double precision edfadis - integer i, iatm1, iatm2, idiff - double precision ckk, sckk,dist,texp - double precision jix,jiy,jiz,ep,fp,scc - - gdfad=0.0d0 - - do i=1, idfadis - - iatm1=idislis(1,i)+1 - iatm2=idislis(2,i)+1 - idiff=abs(iatm1-iatm2) - - jix=c(1,iatm2)-c(1,iatm1) - jiy=c(2,iatm2)-c(2,iatm1) - jiz=c(3,iatm2)-c(3,iatm1) - dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) - - ckk=ck(idiff) - sckk=sck(idiff) - - scc = 0.0d0 - ep = 0.0d0 - fp = 0.0d0 - - write(*,*) 'DIST:', i, dist - write(*,*) 'JIX,JIY,JIZ:', jix, jiy, jiz - - do j = 1, idisnum(i) - - dd = dist-fdist(i,j) - dtmp = dd*dd/ckk - if (dtmp.ge.15.0d0) then - texp = 0.0d0 - else - texp = dfaexp( idint(dtmp*1000)+1 )/sckk - endif - - ep=ep+sccdist(i,j)*texp - fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk - scc=scc+sccdist(i,j) - - write(*,*) 'i,j:', i,j - write(*,*) 'iatm1,iatm2:', iatm1, iatm2 - write(*,*) 'dd,fdist:', dd, fdist(i,j) - write(*,*) 'ck,sck:', ckk, sckk - write(*,*) 'ep,fp:', ep, fp - write(*,*) 'scc:', scc - - enddo - - ep = -ep/scc*wwdist - fp = fp/scc*wwdist - - if(abs(ep).lt.1.0d-20)then - ep=0.0d0 - fp=0.0d0 - endif - - write(*,*) '' - write(*,*) 'ep,fp:', ep, fp - write(*,*) 'edfadis:', edfadis - write(*,*) 'gdfad:', gdfad(:,iatm1) - write(*,*) 'gdfad:', gdfad(:,iatm2) - - edfadis = edfadis + ep*dis_inc - - gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc - gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc - gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc - - gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc - gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc - gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc - - write(*,*) 'ep,fp:', ep, fp - write(*,*) 'edfadis:', edfadis - write(*,*) 'gdfad:', gdfad(:,iatm1) - write(*,*) 'gdfad:', gdfad(:,iatm2) - -C gdfad(1,iatm1) = gdfad(1,iatm1)+jix/dist*fp*dis_inc*wwdist -C gdfad(2,iatm1) = gdfad(2,iatm1)+jiy/dist*fp*dis_inc*wwdist -C gdfad(3,iatm1) = gdfad(3,iatm1)+jiz/dist*fp*dis_inc*wwdist - -C gdfad(1,iatm2) = gdfad(1,iatm2)-jix/dist*fp*dis_inc*wwdist -C gdfad(2,iatm2) = gdfad(2,iatm2)-jiy/dist*fp*dis_inc*wwdist -C gdfad(3,iatm2) = gdfad(3,iatm2)-jiz/dist*fp*dis_inc*wwdist - - enddo - - print*, 'EDFAD:', edfadis - - print*, 'COOR' - do i=1,nres - write(*,'(a,i6,1x,3f12.5)')'DFADC:',i,c(1:3,i) - enddo - - print*, 'FORCE' - do i=1,nres - write(*,'(a,i6,1x,3f14.7)')'DFADG:', i, gdfad(1:3,i) - enddo - - return - end - - subroutine edfat(edfator) -C DFA torsion angle - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,ii, iii - integer iatom(5) - double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) - double precision cwidth, cwidth2 - PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) - - edfator= 0.0d0 - enephi = 0.0d0 - enethe = 0.0d0 - gdfat(:,:) = 0.0d0 - -C START OF PHI ANGLE - do i=1, idfaphi - - aphi = 0.0d0 - do iii=1, 5 - iatom(iii) = iphilis(iii,i)+1 - end do - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) - -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - APHI(1)=TDOT/(DGI*DRIPP) - TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - APHI(2)=TDOT/(DGIP*DRIP3) - - ephi = 0.0d0 - tfphi1=0.0d0 - tfphi2=0.0d0 - scc=0.0d0 - - do j=1, iphinum(i) - DDPS1=APHI(1)-FPHI1(i,j) - DDPS2=APHI(2)-FPHI2(i,j) - - DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 - - if (dtmp.ge.15.0d0) then - ps_tmp = 0.0d0 - else - ps_tmp = dfaexp(idint(dtmp*1000)+1) - endif - - ephi=ephi+sccphi(i,j)*ps_tmp - - tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp - tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp - - scc=scc+sccphi(i,j) -C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), -C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) - ENDDO - - ephi=-ephi/scc*phi_inc*wwangle - tfphi1=tfphi1/scc*phi_inc*wwangle - tfphi2=tfphi2/scc*phi_inc*wwangle - - IF (ABS(EPHI).LT.1d-20) THEN - EPHI=0.0D0 - ENDIF - IF (ABS(TFPHI1).LT.1d-20) THEN - TFPHI1=0.0D0 - ENDIF - IF (ABS(TFPHI2).LT.1d-20) THEN - TFPHI2=0.0D0 - ENDIF - -C FORCE DIRECTION CALCULATION - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DRIPP) - - GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - DM2=GIRPP/(DGI**3*DRIPP) - DM3=GIRPP/(DGI*DRIPP**3) - - DM4=1.0d0/(DGIP*DRIP3) - - GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - DM5=GIRP3/(DGIP**3*DRIP3) - DM6=GIRP3/(DGIP*DRIP3**3) -C FIRST ATOM BY PHI1 - TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 - & +( GIZ* RIPY- GIY* RIPZ)*DM2 - TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 - & +( GIX* RIPZ- GIZ* RIPX)*DM2 - TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 - & +( GIY* RIPX- GIX* RIPY)*DM2 - TDX(1)=TDX(1)*TFPHI1 - TDY(1)=TDY(1)*TFPHI1 - TDZ(1)=TDZ(1)*TFPHI1 -C SECOND ATOM BY PHI1 - TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - TDX(2)=TDX(2)*TFPHI1 - TDY(2)=TDY(2)*TFPHI1 - TDZ(2)=TDZ(2)*TFPHI1 -C SECOND ATOM BY PHI2 - TDX(2)=TDX(2)+ - & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 - & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 - TDY(2)=TDY(2)+ - & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 - & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 - & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 -C THIRD ATOM BY PHI1 - TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 - & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 - TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 - & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 - TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 - & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 - TDX(3)=TDX(3)*TFPHI1 - TDY(3)=TDY(3)*TFPHI1 - TDZ(3)=TDZ(3)*TFPHI1 -C THIRD ATOM BY PHI2 - TDX(3)=TDX(3)+ - & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 - TDY(3)=TDY(3)+ - & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 -C FOURTH ATOM BY PHI1 - TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 - TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 - TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 -C FOURTH ATOM BY PHI2 - TDX(4)=TDX(4)+ - & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 - & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 - & + RIP3X*DM6)*TFPHI2 - TDY(4)=TDY(4)+ - & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 - & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 - & + RIP3Y*DM6)*TFPHI2 - TDZ(4)=TDZ(4)+ - & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 - & -( GIPX*RIPY-RIPX*GIPY)*DM5 - & + RIP3Z*DM6)*TFPHI2 -C FIFTH ATOM BY PHI2 - TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 - TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 - TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 -C END OF FORCE DIRECTION -c force calcuation - do ii=1,5 - gdfat(1,iatom(ii))=gdfat(1,iatom(ii))+tdx(ii) - gdfat(2,iatom(ii))=gdfat(2,iatom(ii))+tdy(ii) - gdfat(3,iatom(ii))=gdfat(3,iatom(ii))+tdz(ii) - enddo -c energy calculation - enephi = enephi + ephi -c end of single assignment statement - ENDDO -C END OF PHI RESTRAINT - -C START OF THETA ANGLE - do i=1, idfathe - - athe = 0.0d0 - do iii=1, 5 - iatom(iii) = iphilis(iii,i)+1 - end do -c iatom(1:5)=ithelis(1:5,i) - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y - GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z - GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ - ATHE(1)=TDOT/(DGI*DGIP) - TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ - ATHE(2)=TDOT/(DGIP*DGIPP) - - ETHE=0.0D0 - TFTHE1=0.0D0 - TFTHE2=0.0D0 - SCC=0.0D0 - TH_TMP=0.0d0 - - do j=1,ithenum(i) - ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) - ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) - dtmp= (ddth1**2+ddth2**2)/cwidth2 - if ( dtmp .ge. 15.0d0) then - th_tmp = 0.0d0 - else - th_tmp = dfaexp ( idint(dtmp*1000)+1 ) - end if - - ethe=ethe+sccthe(i,j)*th_tmp - - tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) - tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) - scc=scc+sccthe(i,j) -C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), -C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) - enddo - - ethe=-ethe/scc*the_inc*wwangle - tfthe1=tfthe1/scc*the_inc*wwangle - tfthe2=tfthe2/scc*the_inc*wwangle - - if (abs(ethe).lt.tenm20) then - ethe=0.0d0 - endif - if (abs(tfthe1).lt.tenm20) then - tfthe1=0.0d0 - endif - if (abs(tfthe2).lt.tenm20) then - tfthe2=0.0d0 - endif - - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DGIP) - DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) - DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) - - DM4=1.0d0/(DGIP*DGIPP) - DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) - DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) - -C FIRST ATOM BY THETA1 - TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 - & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 - TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 - & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 - TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 - & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 -C SECOND ATOM BY THETA1 - TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 - TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 - TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 -C SECOND ATOM BY THETA2 - TDX(2)=TDX(2)+ - & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 - & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 - TDY(2)=TDY(2)+ - & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 - & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 - & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 -C THIRD ATOM BY THETA1 - TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 - & -(GIY*RIZ-GIZ*RIY)*DM2 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 - TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 - & -(GIZ*RIX-GIX*RIZ)*DM2 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 - TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 - & -(GIX*RIY-GIY*RIX)*DM2 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 -C THIRD ATOM BY THETA2 - TDX(3)=TDX(3)+ - & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 - & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 - TDY(3)=TDY(3)+ - & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 - & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 - & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 -C FOURTH ATOM BY THETA1 - TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 - & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 - TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 - & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 - TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 - & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 -C FOURTH ATOM BY THETA2 - TDX(4)=TDX(4)+ - & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 - & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 - & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 - TDY(4)=TDY(4)+ - & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 - & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 - & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 - TDZ(4)=TDZ(4)+ - & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 - & -(GIPX*RIPY-GIPY*RIPX)*DM5 - & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 -C FIFTH ATOM BY THETA2 - TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 - & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 - TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 - & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 - TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 - & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 -C !! END OF FORCE DIRECTION!!!! - do ii=1,5 - gdfat(1,iatom(ii))=gdfat(1,iatom(ii))+tdx(ii) - gdfat(2,iatom(ii))=gdfat(2,iatom(ii))+tdy(ii) - gdfat(3,iatom(ii))=gdfat(3,iatom(ii))+tdz(ii) - enddo -C energy calculation - enethe = enethe + ethe - ENDDO - - edfator = enephi + enethe - - print*, 'EDFAT:',edfator -C print*, 'COOR' -C do i=1,nres-1 -C write(*,'(a,i6,1x,3f12.5)')'DFATC:',i,c(1:3,i) -C enddo - - print*, 'TOR_FORCE' - do i=2,nres-1 - write(*,'(a,i6,1x,3f14.7)')'DFATG:',i,gdfat(1:3,i) - enddo - - - RETURN - END - - subroutine edfan(edfanei) -C DFA neighboring CA restraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,imin - integer kshnum, n1atom - - double precision enenei,tmp_n - double precision pai,hpai - double precision jix,jiy,jiz,ndiff,snorm_nei - double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) - double precision dr,dr2,half,ntmp - - parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) - parameter(pai=3.14159265358979323846D0) - parameter(hpai=1.5707963267948966D0) - parameter(snorm_nei=0.886226925452758D0) - - edfanei = 0.0d0 - enenei = 0.0d0 - gdfan = 0.0d0 - -c print*, 's1:', s1(:) -c print*, 's2:', s2(:) - - do i=1, idfanei - - kshnum= kshell(i) - n1atom= ineilis(i) + 1 -C write(*,*) 'kshnum,n1atom:', kshnum, n1atom - - tmp_n=0.0d0 - ftmp=0.0d0 - dnei=0.0d0 - dist=0.0d0 - t1dx=0.0d0 - t1dy=0.0d0 - t1dz=0.0d0 - t2dx=0.0d0 - t2dy=0.0d0 - t2dz=0.0d0 - -c do j = 1, nres - do j = 2, nres-1 - - if (n1atom.eq.j) cycle - - jix=c(1,j)-c(1,n1atom) - jiy=c(2,j)-c(2,n1atom) - jiz=c(3,j)-c(3,n1atom) - dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) - -C write(*,*) 'N1ATOM,J,DIST:', n1atom, j, dist - - if(kshnum.ne.1)then - if (dist.lt.s1(kshnum).and. - & dist.gt.s2(kshnum-1)) then - - tmp_n=tmp_n+1.0d0 - -c write(*,*) 'case1:',tmp_n - - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum)) then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case2:',tmp_n - ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp -c - elseif(dist.ge.s1(kshnum-1).and. - & dist.le.s2(kshnum-1)) then - dnei=(dist-s1(kshnum-1))/dr2*pai - tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) -c write(*,*) 'case3:',tmp_n - ftmp = hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - - elseif(kshnum.eq.1) then - - if(dist.lt.s1(kshnum))then - - tmp_n=tmp_n+1.0d0 -c write(*,*) 'case4:',tmp_n - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum))then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case5:',tmp_n - ftmp = -hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - endif - enddo - - scc=0.0d0 - enei=0.0d0 - tmp_fnei=0.0d0 - ndiff=0.0d0 - - do imin=1,ineinum(i) - - ndiff = tmp_n-fnei(i,imin) - dtmp = ndiff*ndiff - - if (dtmp.ge.15.0d0) then - ntmp = 0.0d0 - else - ntmp = dfaexp( idint(dtmp*1000) + 1 ) - end if - - enei = enei + sccnei(i,imin)*ntmp - tmp_fnei = tmp_fnei- - & sccnei(i,imin)*ntmp*ndiff*2.0d0 - scc=scc+sccnei(i,imin) - -c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, -c & fnei(i,imin),sccnei(i,imin),enei,scc - enddo - - enei=-enei/scc*snorm_nei*nei_inc*wwnei - tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei - - if (abs(enei).lt.1.0d-20)then - enei=0.0d0 - endif - if (abs(tmp_fnei).lt.1.0d-20) then - tmp_fnei=0.0d0 - endif - -c force calculation - t1dx=t1dx*tmp_fnei - t1dy=t1dy*tmp_fnei - t1dz=t1dz*tmp_fnei - - do j = 2, nres-1 - t2dx(j)=t2dx(j)*tmp_fnei - t2dy(j)=t2dy(j)*tmp_fnei - t2dz(j)=t2dz(j)*tmp_fnei - enddo - - gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx - gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy - gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz - - do j = 2 , nres-1 - gdfan(1,j)=gdfan(1,j)+t2dx(j) - gdfan(2,j)=gdfan(2,j)+t2dy(j) - gdfan(3,j)=gdfan(3,j)+t2dz(j) - enddo -c energy calculation - - enenei=enenei+enei - - enddo - - edfanei=enenei - - print*, 'NRES: ',nres - print*, 'EDFAN:',edfanei - print*, 'COOR' - do i=2,nres-1 - write(*,'(a,i6,1x,3f12.5)')'DFANC:',i,c(1:3,i) - enddo - - print*, 'NEI_FORCE' - do i=2,nres-1 - write(*,'(a,i6,1x,3f14.7)')'DFANG:',i,gdfan(1:3,i) - enddo - - return - end - - subroutine edfab(edfabeta) - - implicit real*8 (a-h,o-z) - - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - real*8 pai - parameter(pai=3.14159265358979323846d0) -C sheet variables - real*8 bx(maxres),by(maxres),bz(maxres) - real*8 vbet(maxres,maxres) - real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) - real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) - real*8 vbeta,vbetp,vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - real*8 dp45,dm45,w_beta - - common /sheca/ bx,by,bz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - common /shef/ shefx, shefy, shefz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta -C End of sheet variables - - integer i,j - double precision enebet - - enebet=0.0d0 - bx=0.0d0;by=0.0d0;bz=0.0d0 - shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 - - gdfab=0.0d0 - -c do i=1,nres - do i=2,nres-1 - bx(i-1)=c(1,i) - by(i-1)=c(2,i) - bz(i-1)=c(3,i) - enddo - - dca=0.25d0**2 - dshe=0.3d0**2 - ulhb=5.0d0 - uldhb=5.0d0 - ulnex=cos(60.0d0/180.0d0*pai) - - dlhb=1.0d0 - dldhb=1.0d0 - - dnex=0.3d0**2 - - c00=cos((1.0d0+10.0d0/180.0d0)*pai) - s00=sin((1.0d0+10.0d0/180.0d0)*pai) - - w_beta=0.5d0 - dp45=w_beta - dm45=w_beta - -C END OF INITIALIZATION - - nca=nres-2 - - call angvectors(nca) - call sheetforce(nca,wshet,dfaexp) - -c end of sheet energy and force - -c do j=1,nres - do j=2,nres-1 - shetfx(j-1)=shetfx(j-1)*beta_inc - shetfy(j-1)=shetfy(j-1)*beta_inc - shetfz(j-1)=shetfz(j-1)*beta_inc -c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) - enddo - - vbeta=vbeta*beta_inc - enebet=vbeta - edfabeta=enebet - -c do j=1,nres - do j=2,nres-1 - gdfab(1,j)=gdfab(1,j)-shetfx(j-1) - gdfab(2,j)=gdfab(2,j)-shetfy(j-1) - gdfab(3,j)=gdfab(3,j)-shetfz(j-1) - enddo - - print*, 'EDFAB:',edfabeta -C print*, 'COOR' -C do i=2,nres-1 -C write(*,'(a,i6,1x,3f12.5)')'DFABC:',i,c(1:3,i) -C enddo - - print*, 'BETA_FORCE' - do i=2,nres-1 - write(*,'(a,i6,1x,3f14.7)')'DFABG:',i,gdfab(1:3,i) - enddo - - return - end -C------------------------------------------------------------------------------- - subroutine angvectors(nca) -c implicit real*4(a-h,o-z) - implicit none - integer nca - integer maxca - parameter(maxca=800) - real*8 pai,zero - parameter(PAI=3.14159265358979323846D0,zero=0.0d0) - - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 cph(maxca),cth(maxca) - real*8 ulcos(maxca) - real*8 p,c - integer i, ip, ipp, ip3, j - real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) - real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz - real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz - real*8 cix, ciy, ciz, cipx, cipy, cipz - real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g - real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 - real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 - real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 - real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri - real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim - real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm - real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm - real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm - real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr - real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz - real*8 grpp,gx,gy,gz - real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz - real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 - integer inb,nmax,iselect - - common /sheca/ bx,by,bz - common /difvec/ rx, ry, rz - common /ulang/ ulcos - common /phys1/ inb,nmax,iselect - common /phys4/ p,c - common /kyori2/ dis - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - & apmmz,apm3x,apm3y,apm3z - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - & atmmz,atm3x,atm3y,atm3z - common /coscos/ cph,cth - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C------------------------------------------------------------------------------- -c write(*,*) 'inside angvectors' -C initialize - p=0.1d0 - c=1.0d0 - inb=nca - cph=zero; cth=zero; sth=zero - apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero - apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero - atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero - atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero - astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero - astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero - astm3z=zero -C end of initialize -C r[x,y,z] calc and distance calculation - rx=zero;ry=zero;rz=zero - - do i=1,inb - do j=1,inb - rx(i,j)=bx(j)-bx(i) - ry(i,j)=by(j)-by(i) - rz(i,j)=bz(j)-bz(i) - dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) -c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -c write(*,*) 'dis(i,j):',i,j,dis(i,j) - enddo - enddo -c end of r[x,y,z] calc -C cos calc - do i=1,inb-2 - ip=i+1 - ipp=i+2 - - if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then - ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) - $ +rz(i,ip)*rz(ip,ipp) - ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) - endif - enddo -c end of virtual bond angle -c write(*,*) 'inside angvectors1' - do i=1,inb-3 - ip=i+1 - ipp=i+2 - ip3=i+3 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - rippx=bx(ip3)-bx(ipp) - rippy=by(ip3)-by(ipp) - rippz=bz(ip3)-bz(ipp) - - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - gpx=ripy*rippz-ripz*rippy - gpy=ripz*rippx-ripx*rippz - gpz=ripx*rippy-ripy*rippx - gpcrp_x=gpy*ripz-gpz*ripy - gpcrp_y=gpz*ripx-gpx*ripz - gpcrp_z=gpx*ripy-gpy*ripx - d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) - gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy - & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy - - if(i.ge.2) then - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - drim=dis(i-1,i) - drim3=drim**3 - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - endif -c write(*,*) 'inside angvectors2' - if(i.ge.3) then - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - drimm=dis(i-2,i-1) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - endif - - if(i.ge.4) then - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - endif - - dri=dis(i,i+1) - drip=dis(i+1,i+2) - dripp=dis(i+2,i+3) - dri3=dri**3 - dg=sqrt(gx**2+gy**2+gz**2) - dgp=sqrt(gpx**2+gpy**2+gpz**2) - dg3=dg**3 - - ggp=gx*gpx+gy*gpy+gz*gpz - grpp=gx*rippx+gy*rippy+gz*rippz - - if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 - & .and.d_gpcrp.gt.0.0D0) then - cph(i)=grpp/dg/dripp - cth(i)=ggp/dg/dgp - sth(i)=gpcrp__g/d_gpcrp/dg - else -c - cph(i)=1.0D0 - cth(i)=1.0D0 - sth(i)=0.0D0 - endif - -c write(*,*) 'inside angvectors3' - - if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 - & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then - d10=1.0D0/(dg*dgp) - d11=ggp/(dg3*dgp) - d12=1.0D0/(dg*dripp) - d13=grpp/(dg3*dripp) - sd10=1.0D0/(d_gpcrp*dg) - sd11=gpcrp__g/(d_gpcrp*dg3) - else - d10=0.0D0 - d11=0.0D0 - d12=0.0D0 - d13=0.0D0 - sd10=0.0D0 - sd11=0.0D0 - endif - - atx(i)=(ripz*gpy-ripy*gpz)*d10 - & -(gy*ripz-gz*ripy)*d11 - aty(i)=(ripx*gpz-ripz*gpx)*d10 - & -(gz*ripx-gx*ripz)*d11 - atz(i)=(ripy*gpx-ripx*gpy)*d10 - & -(gx*ripy-gy*ripx)*d11 - astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz - & +ripy*gpy*ripx-gpx*ripz**2) - & -sd11*(gy*ripz-gz*ripy) - asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx - & -gpy*ripx**2+gpz*ripy*ripz) - & -sd11*(-gx*ripz+gz*ripx) - astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 - & -gpz*ripy**2+ripz*gpx*ripx) - & -sd11*(gx*ripy-gy*ripx) - apx(i)=(ripz*rippy-ripy*rippz)*d12 - & -(gy*ripz-gz*ripy)*d13 - apy(i)=(ripx*rippz-ripz*rippx)*d12 - & -(gz*ripx-gx*ripz)*d13 - apz(i)=(ripy*rippx-ripx*rippy)*d12 - & -(gx*ripy-gy*ripx)*d13 - - if(i.ge.2) then - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 - & .and.d_gcr3.gt.0.0D0) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - endif - - if(i.ge.3) then - if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif - -c write(*,*) 'inside angvectors4' - -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -c********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - - if(i.ge.4) then - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -c********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - endif - enddo -c******************************************************************************* - -c write(*,*) 'inside angvectors5' - - do i=inb-2,inb - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - drim=dis(i-1,i) - drimm=dis(i-2,i-1) - drim3=drim**3 - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -cc********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - - if(i.le.inb-1) then - ip=i+1 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - dri=dis(i,i+1) - dri3=dri**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - - if(dgm3.gt.0.0D0.and. - & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -cc********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - -c write(*,*) 'inside angvectors6' - - if(i.eq.inb-2) then - ipp=i+2 - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - dg=sqrt(gx**2+gy**2+gz**2) - dg3=dg**3 - drip=dis(i+1,i+2) - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - if(dgm3.gt.0.0D0.and. - & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 - & ) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** -c - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - - endif - enddo - - return - end -c END of angvectors -c------------------------------------------------------------------------------- -C--------------------------------------------------------------------------------- - subroutine sheetforce(nca,wshet,dfaexp) - implicit none -C JYLEE -c this should be matched with dfa.fcm - integer maxca - parameter(maxca=800) -cc********************************************************************** - integer nca - integer i,k - integer inb,nmax,iselect - - real*8 dfaexp(15001) - - real*8 vbeta,vbetp,vbetm - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) - real*8 vbet(maxca,maxca) - real*8 wshet(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - - inb=nca - do i=1,inb - shetfx(i)=0.0D0 - shetfy(i)=0.0D0 - shetfz(i)=0.0D0 - enddo - - do k=1,12 - do i=1,inb - shefx(i,k)=0.0D0 - shefy(i,k)=0.0D0 - shefz(i,k)=0.0D0 - enddo - enddo - - call sheetene(nca,wshet,dfaexp) - call sheetforce1 - - 887 format(a,1x,i6,3x,f12.8) - 888 format(a,1x,i4,1x,i4,3x,f12.8) - 889 format(a,1x,i4,3x,f12.8) - !write(2,*) 'coord : ' - do i=1,inb - !write(2,887) 'bx:',i,bx(i) - !write(2,887) 'by:',i,by(i) - !write(2,887) 'bz:',i,bz(i) - enddo - !write(2,*) 'After sheetforce1' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce5 - - !write(2,*) 'After sheetforce5' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce6 - - !write(2,*) 'After sheetforce6' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce11 - - !write(2,*) 'After sheetforce11' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce12 - - !write(2,*) 'After sheetforce12' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - do i=1,inb - do k=1,12 - shetfx(i)=shetfx(i)+shefx(i,k) - shetfy(i)=shetfy(i)+shefy(i,k) - shetfz(i)=shetfz(i)+shefz(i,k) - enddo - enddo - !write(2,*) 'Beta Finished' - do i=1,inb - !write(2,889) 'shetfx : ',i,shetfx(i) - !write(2,889) 'shetfy : ',i,shetfy(i) - !write(2,889) 'shetfz : ',i,shetfz(i) - enddo - - return - end -C end sheetforce -c------------------------------------------------------------------------------- - subroutine sheetene(nca,wshet,dfaexp) - implicit none - integer maxca - parameter(maxca=800) -cc****************************************************************************** - - real*8 dfaexp(15001) - real*8 dtmp1, dtmp2, dtmp3 - - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 ulcos(maxca) -cc********************************************************************** - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 wshet(maxca,maxca) - real*8 dp45, dm45, w_beta - real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb - integer nca - integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect - real*8 uum, uup - real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -cc********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth - - real*8 r_pair_mat(maxca,maxca) - common /beta_p/ r_pair_mat -C------------------------------------------------------------------------------- - r_pair_mat = 0.0d0 - do i=1,inb - do j=1,inb - r_pair_mat(i,j)=wshet(i,j) -c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) - enddo - enddo -c stop -c - vbeta=0.0D0 - vbetp=0.0D0 - vbetm=0.0D0 - - do i=1,inb-7 - do j=i+4,inb-3 - ip=i+1 - ipp=i+2 - jp=j+1 - jpp=j+2 -cc********************************************************************** - y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 - & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 - y1=-0.5d0*y1/dca - y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 - & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 - y2=-0.5d0*y2/dnex - y=y1+y2 - - yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb - - pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) - $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) - pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) - $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) - pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) - $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) - pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) - $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) - - yshe1=pin1(i,j)**2+pin2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pin3(i,j)**2+pin4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -C write(*,*) 'dis(i,j):',i,j,dis(i,j) -C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) -C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) -C write(*,*) 'pin1:',pin1(i,j) -C write(*,*) 'pin2:',pin2(i,j) -C write(*,*) 'pin3:',pin3(i,j) -C write(*,*) 'pin4:',pin4(i,j) - -C write(*,*) 'y:',y -C write(*,*) 'yy1:',yy1 -C write(*,*) 'yy2:',yy2 -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -c - - dtmp1 = y+yy1+yshe1 - dtmp2 = y+yy2+yshe2 - dtmp3 = y+yy1+yy2+yshe1+yshe2 - -C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 -C write(*,*)'2', y,yy1,yy2 -C write(*,*)'3', yshe1,yshe2 - - if (dtmp3.le.-15.0d0) then -c vbetap(i,j)=-dp45*exp(dtmp3) - vbetap(i,j)=0.0d0 - else - vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) - end if - - if (dtmp1.le.-15.0d0) then -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) - vbetap1(i,j)=0.0d0 - else - vbetap1(i,j)=-r_pair_mat(i+1,j+1) - $ *dfaexp(idint(-dtmp1*1000)+1) - end if - - if (dtmp2.le.-15.0d0) then -C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) - vbetap2(i,j)=0.0d0 - else - vbetap2(i,j)=-r_pair_mat(i+2,j+2) - $ *dfaexp(idint(-dtmp2*1000)+1) - end if - -c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) -c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) -! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) - - - yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb - - pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) - $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) - pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) - $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) - pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) - $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) - pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) - $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) - - yshe1=pina1(i,j)**2+pina2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pina3(i,j)**2+pina4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'pina1:',pina1(i,j) -C write(*,*) 'pina2:',pina2(i,j) -C write(*,*) 'pina3:',pina3(i,j) -C write(*,*) 'pina4:',pina4(i,j) -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -C write(*,*) 'dshe:',dshe - - dtmp3=y+yy1+yy2+yshe1+yshe2 - dtmp1=y+yy1+yshe1 - dtmp2=y+yy2+yshe2 - - if(dtmp3 .le. -15.0d0) then -c vbetam(i,j)=-dm45*exp(dtmp3) - vbetam(i,j)=0.0d0 - else - vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) - end if - - if(dtmp1 .le. -15.0d0) then -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) - vbetam1(i,j)=0.0d0 - else - vbetam1(i,j)=-r_pair_mat(i+1,j+2) - $ *dfaexp(idint(-dtmp1*1000)+1) - end if - - if(dtmp2.le.-15.0d0) then -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) - vbetam2(i,j)=0.0d0 - else - vbetam2(i,j)=-r_pair_mat(i+2,j+1) - $ *dfaexp(idint(-dtmp2*1000)+1) - end if - -c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) -! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) - - uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) - uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) - -c write(*,*) 'uup,uum:', uup, uum - -c uup=vbetap1(i,j)+vbetap2(i,j) -c uum=vbetam1(i,j)+vbetam2(i,j) - - vbet(i,j)=uup+uum - vbetp=vbetp+uup - vbetm=vbetm+uum - vbeta=vbeta+vbet(i,j) - -c write(*,*) 'uup,uum:',uup,uum -c write(*,*) 'vbetap(i,j):',vbetap(i,j) -c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -c write(*,*) 'vbetam(i,j):',vbetam(i,j) -c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -c write(*,*) 'uup:',uup -c write(*,*) 'uum:',uum -c write(*,*) 'vbetp:',vbetp -c write(*,*) 'vbetm:',vbetm -c write(*,*) 'vbet(i,j):',vbet(i,j) -c stop - - enddo - enddo - -! do i=1,inb-7 -! do j=i+4,inb-3 -! write(*,*) 'I,J:', i,j -! write(*,*) 'vbetap(i,j):',vbetap(i,j) -! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -! write(*,*) 'vbetam(i,j):',vbetam(i,j) -! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -! write(*,*) 'vbet(i,j):',vbet(i,j) -! enddo -! enddo - - return - end -c------------------------------------------------------------------------------- - subroutine sheetforce1 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 ulcos(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 w_beta,dp45, dm45 - real*8 vbeta, vbetp, vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect - - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - $ atmmz,atm3x,atm3y,atm3z - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - $ apmmz,apm3x,apm3y,apm3z - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -c c********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - $ astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C-------------------------------------------------------------------------------- -c local variables - integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp - real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 - real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 - real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 - real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 -C-------------------------------------------------------------------------------- - do i=4,inb-4 - im3=i-3 - imm=i-2 - im=i-1 - c1=(cth(im3)*c00+sth(im3)*s00-1)/dca - v1=0.0D0 - do j=i+1,inb-3 - v1=v1+vbet(im3,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - dmm=cc1/(dis(imm,im)*dis(im,i)) - dmm__=cc1*ulcos(imm)/dis(im,i)**2 - fx=rx(imm,im)*dmm-rx(im,i)*dmm__ - fy=ry(imm,im)*dmm-ry(im,i)*dmm__ - fz=rz(imm,im)*dmm-rz(im,i)*dmm__ - fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 - fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 - fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 - shefx(i,1)=fx*v1 - shefy(i,1)=fy*v1 - shefz(i,1)=fz*v1 - enddo - - do i=3,inb-5 - imm=i-2 - im=i-1 - ip=i+1 - c2=(cth(imm)*c00+sth(imm)*s00-1)/dca - v2=0.0D0 - do j=i+2,inb-3 - v2=v2+vbet(imm,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - cc2=(ulcos(im)-ulnex)/dnex - dmm1=cc1/(dis(imm,im)*dis(im,i)) - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm1__=cc1*ulcos(imm)/dis(im,i)**2 - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 -cc********************************************************************** - fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 - fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 - fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 - fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 - fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 - fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 - shefx(i,2)=fx*v2 - shefy(i,2)=fy*v2 - shefz(i,2)=fz*v2 - enddo - do i=2,inb-6 - im=i-1 - ip=i+1 - ipp=i+2 - c3=(cth(im)*c00+sth(im)*s00-1)/dca - v3=0.0D0 - do j=i+3,inb-3 - v3=v3+vbet(im,j) - enddo - cc2=(ulcos(im)-ulnex)/dnex - cc3=(ulcos(i)-ulnex)/dnex - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ - fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 - fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 - fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 - shefx(i,3)=fx*v3 - shefy(i,3)=fy*v3 - shefz(i,3)=fz*v3 - enddo - do i=1,inb-7 - ip=i+1 - ipp=i+2 - c4=(cth(i)*c00+sth(i)*s00-1)/dca - v4=0.0D0 - do j=i+4,inb-3 - v4=v4+vbet(i,j) - enddo - cc3=(ulcos(i)-ulnex)/dnex - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ - fx=fx+(atx(i)*c00+astx(i)*s00)*c4 - fy=fy+(aty(i)*c00+asty(i)*s00)*c4 - fz=fz+(atz(i)*c00+astz(i)*s00)*c4 - shefx(i,4)=fx*v4 - shefy(i,4)=fy*v4 - shefz(i,4)=fz*v4 - enddo - do j=8,inb - jm3=j-3 - jmm=j-2 - jm=j-1 - c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca - v7=0.0D0 - do i=1,j-7 - v7=v7+vbet(i,jm3) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - dmm=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 - fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ - fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ - fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ - fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 - fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 - fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 - shefx(j,7)=fx*v7 - shefy(j,7)=fy*v7 - shefz(j,7)=fz*v7 - enddo - do j=7,inb-1 - jm=j-1 - jmm=j-2 - jp=j+1 - c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca - v8=0.0D0 - do i=1,j-6 - v8=v8+vbet(i,jmm) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - cc8=(ulcos(jm)-ulnex)/dnex - dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 - fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 - fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 - fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 - fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 - fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 - shefx(j,8)=fx*v8 - shefy(j,8)=fy*v8 - shefz(j,8)=fz*v8 - enddo - - do j=6,inb-2 - jm=j-1 - jp=j+1 - jpp=j+2 - c9=(cth(jm)*c00+sth(jm)*s00-1)/dca - v9=0.0D0 - do i=1,j-5 - v9=v9+vbet(i,jm) - enddo - cc8=(ulcos(jm)-ulnex)/dnex - cc9=(ulcos(j)-ulnex)/dnex - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ - fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 - fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 - fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 - shefx(j,9)=fx*v9 - shefy(j,9)=fy*v9 - shefz(j,9)=fz*v9 - enddo - - do j=5,inb-3 - jp=j+1 - jpp=j+2 - c10=(cth(j)*c00+sth(j)*s00-1)/dca - v10=0.0D0 - do i=1,j-4 - v10=v10+vbet(i,j) - enddo - cc9=(ulcos(j)-ulnex)/dnex - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ - fx=fx+(atx(j)*c00+astx(j)*s00)*c10 - fy=fy+(aty(j)*c00+asty(j)*s00)*c10 - fz=fz+(atz(j)*c00+astz(j)*s00)*c10 - shefx(j,10)=fx*v10 - shefy(j,10)=fy*v10 - shefz(j,10)=fz*v10 - enddo - - return - end -c---------------------------------------------------------------------------- - subroutine sheetforce5 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -c******************************************************************************** -c local variables - integer i,imm,im,jp,jpp,j - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z - real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b -c******************************************************************************** - do i=3,inb-5 - imm=i-2 - im=i-1 - do j=i+2,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jpp)-ulhb)/dlhb - y1x=rx(jpp,i)/dis(i,jpp) - y1y=ry(jpp,i)/dis(i,jpp) - y1z=rz(jpp,i)/dis(i,jpp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(im,jp)*dis(im,i)) - yyy3=pin1(imm,j)/(dis(im,i)**2) - yy3=-pin1(imm,j)/dshe - y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 - y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 - y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 - - yy44=1.0D0/(dis(i,jpp)*dis(im,i)) - yyy4a=pin3(imm,j)/(dis(i,jpp)**2) - yyy4b=pin3(imm,j)/(dis(im,i)**2) - yy4=-pin3(imm,j)/dshe - y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) - $ -yyy4b*rx(im,i))*yy4 - y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) - $ -yyy4b*ry(im,i))*yy4 - y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) - $ -yyy4b*rz(im,i))*yy4 - - - yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy5=pin4(imm,j)/(dis(i,jpp)**2) - yy5=-pin4(imm,j)/dshe - y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 - y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 - y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) - $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) - $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) - $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - - yy6=-(dis(i,jp)-uldhb)/dldhb - y6x=rx(jp,i)/dis(i,jp) - y6y=ry(jp,i)/dis(i,jp) - y6z=rz(jp,i)/dis(i,jp) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(im,jpp)*dis(im,i)) - yyy8=pina1(imm,j)/(dis(im,i)**2) - yy8=-pina1(imm,j)/dshe - y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 - y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 - y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 - - yy99=1.0D0/(dis(jp,i)*dis(im,i)) - yyy9a=pina3(imm,j)/(dis(jp,i)**2) - yyy9b=pina3(imm,j)/(dis(im,i)**2) - yy9=-pina3(imm,j)/dshe - y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) - $ -yyy9b*rx(im,i))*yy9 - y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) - $ -yyy9b*ry(im,i))*yy9 - y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) - $ -yyy9b*rz(im,i))*yy9 - - yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) - yyy10=pina4(imm,j)/(dis(jp,i)**2) - yy10=-pina4(imm,j)/dshe - y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 - y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 - y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) - $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) - $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) - $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - - enddo - enddo - - return - end -c--------------------------------------------------------------------------c - subroutine sheetforce6 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer i,imm,im,jp,jpp,j,ip - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 - real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b -C******************************************************************************** - do i=2,inb-6 - ip=i+1 - im=i-1 - do j=i+3,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jp)-ulhb)/dlhb - y1x=rx(jp,i)/dis(i,jp) - y1y=ry(jp,i)/dis(i,jp) - y1z=rz(jp,i)/dis(i,jp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(i,jp)*dis(i,ip)) - yyy3a=pin1(im,j)/(dis(i,jp)**2) - yyy3b=pin1(im,j)/(dis(i,ip)**2) - yy3=-pin1(im,j)/dshe - y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) - $ +yyy3b*rx(i,ip))*yy3 - y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) - $ +yyy3b*ry(i,ip))*yy3 - y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) - $ +yyy3b*rz(i,ip))*yy3 - - yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) - yyy4=pin2(im,j)/(dis(i,jp)**2) - yy4=-pin2(im,j)/dshe - y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 - y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 - y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 - - yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) - yyy5=pin3(im,j)/(dis(i,ip)**2) - yy5=-pin3(im,j)/dshe - y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 - y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 - y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) - $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) - $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) - $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) - - yy6=-(dis(jpp,i)-uldhb)/dldhb - y6x=rx(jpp,i)/dis(jpp,i) - y6y=ry(jpp,i)/dis(jpp,i) - y6z=rz(jpp,i)/dis(jpp,i) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) - yyy8a=pina1(im,j)/(dis(i,jpp)**2) - yyy8b=pina1(im,j)/(dis(i,ip)**2) - yy8=-pina1(im,j)/dshe - y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) - $ +yyy8b*rx(i,ip))*yy8 - y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) - $ +yyy8b*ry(i,ip))*yy8 - y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) - $ +yyy8b*rz(i,ip))*yy8 - - yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy9=pina2(im,j)/(dis(i,jpp)**2) - yy9=-pina2(im,j)/dshe - y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 - y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 - y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 - - yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) - yyy10=pina3(im,j)/(dis(i,ip)**2) - yy10=-pina3(im,j)/dshe - y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 - y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 - y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) - $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) - $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) - $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce11 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -C******************************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 - real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 -C******************************************************************************** - - do j=7,inb-1 - jm=j-1 - jmm=j-2 - do i=1,j-6 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ipp,j)-ulhb)/dlhb - y1x=rx(ipp,j)/dis(ipp,j) - y1y=ry(ipp,j)/dis(ipp,j) - y1z=rz(ipp,j)/dis(ipp,j) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) - yyy3=pin2(i,jmm)/(dis(jm,j)**2) - yy3=-pin2(i,jmm)/dshe - y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 - y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 - y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 - - yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) - yyy4=pin3(i,jmm)/(dis(ipp,j)**2) - yy4=-pin3(i,jmm)/dshe - y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 - y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 - y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 - - yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) - yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) - yyy5b=pin4(i,jmm)/(dis(jm,j)**2) - yy5=-pin4(i,jmm)/dshe - y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) - $ -yyy5b*rx(jm,j))*yy5 - y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) - $ -yyy5b*ry(jm,j))*yy5 - y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) - $ -yyy5b*rz(jm,j))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) - $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) - $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) - $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - - yy6=-(dis(ip,j)-uldhb)/dldhb - y6x=rx(ip,j)/dis(ip,j) - y6y=ry(ip,j)/dis(ip,j) - y6z=rz(ip,j)/dis(ip,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy8=pina1(i,jmm)/(dis(ip,j)**2) - yy8=-pina1(i,jmm)/dshe - y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 - y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 - y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 - - yy99=1.0D0/(dis(ip,j)*dis(jm,j)) - yyy9a=pina2(i,jmm)/(dis(ip,j)**2) - yyy9b=pina2(i,jmm)/(dis(jm,j)**2) - yy9=-pina2(i,jmm)/dshe - y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) - $ -yyy9b*rx(jm,j))*yy9 - y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) - $ -yyy9b*ry(jm,j))*yy9 - y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) - $ -yyy9b*rz(jm,j))*yy9 - - yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) - yyy10=pina4(i,jmm)/(dis(jm,j)**2) - yy10=-pina4(i,jmm)/dshe - y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 - y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 - y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) - $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) - $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) - $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce12 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp,jp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 -!c*************************************************************************c - do j=6,inb-2 - jp=j+1 - jm=j-1 - do i=1,j-5 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ip,j)-ulhb)/dlhb - y1x=rx(ip,j)/dis(ip,j) - y1y=ry(ip,j)/dis(ip,j) - y1z=rz(ip,j)/dis(ip,j) - y11x=y1x*yy1 - y11y=y1y*yy1 - y11z=y1z*yy1 - - yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy3=pin1(i,jm)/(dis(ip,j)**2) - yy3=-pin1(i,jm)/dshe - y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 - y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 - y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 - yy44=1.0D0/(dis(ip,j)*dis(j,jp)) - - yyy4a=pin2(i,jm)/(dis(ip,j)**2) - yyy4b=pin2(i,jm)/(dis(j,jp)**2) - yy4=-pin2(i,jm)/dshe - y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) - $ +yyy4b*rx(j,jp))*yy4 - y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) - $ +yyy4b*ry(j,jp))*yy4 - y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) - $ +yyy4b*rz(j,jp))*yy4 - - yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) - yyy5=pin4(i,jm)/(dis(j,jp)**2) - yy5=-pin4(i,jm)/dshe - y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 - y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 - y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) - $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) - $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) - $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - -! shefx(j,12)=shefx(j,12) -! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) -! shefy(j,12)=shefy(j,12) -! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) -! shefz(j,12)=shefz(j,12) -! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - - yy6=-(dis(ipp,j)-uldhb)/dldhb - y6x=rx(ipp,j)/dis(ipp,j) - y6y=ry(ipp,j)/dis(ipp,j) - y6z=rz(ipp,j)/dis(ipp,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) - yyy8=pina2(i,jm)/(dis(j,jp)**2) - yy8=-pina2(i,jm)/dshe - y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 - y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 - y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 - - yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) - yyy9=pina3(i,jm)/(dis(j,ipp)**2) - yy9=-pina3(i,jm)/dshe - y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 - y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 - y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 - - yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) - yyy10a=pina4(i,jm)/(dis(j,ipp)**2) - yyy10b=pina4(i,jm)/(dis(j,jp)**2) - yy10=-pina4(i,jm)/dshe - y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) - $ +yyy10b*rx(j,jp))*yy10 - y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) - $ +yyy10b*ry(j,jp))*yy10 - y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) - $ +yyy10b*rz(j,jp))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) - $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) - $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) - $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) - - ENDDO - ENDDO - - RETURN - END -C=============================================================================== diff --git a/source/unres/src_CSA/dfa.F.org b/source/unres/src_CSA/dfa.F.org deleted file mode 100644 index a523885..0000000 --- a/source/unres/src_CSA/dfa.F.org +++ /dev/null @@ -1,3100 +0,0 @@ - subroutine init_dfa_vars - - include 'DIMENSIONS' - include 'COMMON.DFA' - - integer ii - -C Number of restraints - idisnum = 0 - iphinum = 0 - ithenum = 0 - ineinum = 0 - - idislis = 0 - iphilis = 0 - ithelis = 0 - ineilis = 0 - jneilis = 0 - jneinum = 0 - kshell = 0 - fnei = 0 -C For beta - nca = 0 - icaidx = 0 - -C real variables -CC WEIGHTS for each min - sccdist = 0.0d0 - fdist = 0.0d0 - sccphi = 0.0d0 - sccthe = 0.0d0 - sccnei = 0.0d0 - fphi1 = 0.0d0 - fphi2 = 0.0d0 - fthe1 = 0.0d0 - fthe2 = 0.0d0 -C energies - edfatot = 0.0d0 - edfadis = 0.0d0 - edfaphi = 0.0d0 - edfathe = 0.0d0 - edfanei = 0.0d0 - edfabet = 0.0d0 -C weights for each E term -C these should be identical with - dis_inc = 0.0d0 - phi_inc = 0.0d0 - the_inc = 0.0d0 - nei_inc = 0.0d0 - beta_inc = 0.0d0 - wshet = 0.0d0 -C precalculate exp table! - dfaexp = 0.0d0 - do ii = 1, 15001 - dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) - end do - return - end - - - subroutine read_dfa_info -C -C read fragment informations -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DFA' - - -C NOTE THAT FILENAMES are FIXED, CURRENTLY!! -C THIS SHOULD BE MODIFIED!! - - character*320 buffer - integer iodfa - parameter(iodfa=89) - - integer i, j, nval - integer ica1, ica2,ica3,ica4,ica5 - integer ishell, inca, itmp,iitmp - double precision wtmp -C -C READ DISTANCE -C - open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) - goto 34 - 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 34 continue - write(iout,'(a)') 'dist_dfa.dat is opened!' -C read title - read(iodfa, '(a)') buffer -C read number of restraints - read(iodfa, '(i)') IDFADIS - read(iodfa, *) dis_inc - do i=1, idfadis - read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval - - idisnum(i)=nval - idislis(1,i)=ica1 - idislis(2,i)=ica2 - - do j=1, nval - read(iodfa,*) tmp - fdist(i,j) = tmp - enddo - - do j=1, nval - read(iodfa,*) tmp - sccdist(i,j) = tmp - enddo - - enddo - close(iodfa) - -C READ ANGLE RESTRAINTS -C PHI RESTRAINTS - open(iodfa, file='phi_dfa.dat',status='old',err=35) - goto 36 - 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - - 36 continue - write(iout,'(a)') 'phi_dfa.dat is opened!' - -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFAPHI - read(iodfa,*) phi_inc - do i=1, idfaphi - read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - iphinum(i)=nval - - iphilis(1,i)=ica1 - iphilis(2,i)=ica2 - iphilis(3,i)=ica3 - iphilis(4,i)=ica4 - iphilis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fphi1(i,j) = tmp1 - fphi2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccphi(i,j) = tmp - enddo - - enddo - close(iodfa) - -C THETA RESTRAINTS - open(iodfa, file='theta_dfa.dat',status='old',err=41) - goto 42 - 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 42 continue - write(iout,'(a)') 'theta_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFATHE - read(iodfa,*) the_inc - - do i=1, idfathe - read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - ithenum(i)=nval - - ithelis(1,i)=ica1 - ithelis(2,i)=ica2 - ithelis(3,i)=ica3 - ithelis(4,i)=ica4 - ithelis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fthe1(i,j) = tmp1 - fthe2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccthe(i,j) = tmp - enddo - - enddo - close(iodfa) -C END of READING ANGLE RESTRAINT! - -C NUMBER OF NEIGHBOR CAs - open(iodfa,file='nei_dfa.dat',status='old',err=37) - goto 38 - 37 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 38 continue - write(iout,'(a)') 'nei_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') idfanei - read(iodfa,*) nei_inc - - do i=1, idfanei - read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval - - ineilis(i)=ica1 - kshell(i)=ishell - ineinum(i)=nval - - do j=1, nval - read(iodfa,*) inca - fnei(i,j) = inca -C write(*,*) 'READ NEI:',i,j,fnei(i,j) - enddo - - do j=1, nval - read(iodfa,*) tmp - sccnei(i,j) = tmp - enddo - - enddo - close(iodfa) -C END OF NEIGHBORING CA - -C READ BETA RESTRAINT - open(iodfa, file='beta_dfa.dat',status='old',err=39) - goto 40 - 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' - stop - 40 continue - write(iout,'(a)') 'beta_dfa.dat is opened!' - - read(iodfa,'(a)') buffer - read(iodfa,'(i)') itmp - read(iodfa,*) beta_inc - - do i=1,itmp - read(iodfa,*) ica1, iitmp - do j=1,itmp - read(iodfa,*) wtmp - wshet(i,j) = wtmp -c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) - enddo - enddo - - close(iodfa) -C END OF BETA RESTRAINT - - return - END - - subroutine edfad(edfadis) - - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - double precision edfadis - integer i, iatm1, iatm2,idiff - double precision ckk, sckk,dist,texp - double precision jix,jiy,jiz,ep,fp,scc - - gdfad=0.0d0 - - do i=1, idfadis - - iatm1=idislis(1,i) - iatm2=idislis(2,i) - idiff = abs(iatm1-iatm2) - - JIX=c(1,iatm2)-c(1,iatm1) - JIY=c(2,iatm2)-c(2,iatm1) - JIZ=c(3,iatm2)-c(3,iatm1) - DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) - - ckk=ck(idiff) - sckk=sck(idiff) - - scc = 0.0d0 - ep = 0.0d0 - fp = 0.0d0 - - do j=1,idisnum(i) - - dd = dist-fdist(i,j) - dtmp = dd*dd/ckk - if (dtmp.ge.15.0d0) then - texp = 0.0d0 - else - texp = dfaexp( idint(dtmp*1000)+1 )/sckk - endif - - ep=ep+sccdist(i,j)*texp - fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk - scc=scc+sccdist(i,j) -C write(*,'(2i8,6f12.5)') i, j, dist, -C & fdist(i,j), ep, fp, sccdist(i,j), scc - - enddo - - ep = -ep/scc - fp = fp/scc - - IF(ABS(EP).lt.1.0d-20)THEN - EP=0.0D0 - ENDIF - IF (ABS(FP).lt.1.0d-20) THEN - FP=0.0D0 - ENDIF - - edfadis=edfadis+ep*dis_inc*wwdist - - gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist - - gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist - - enddo - - return - end - - subroutine edfat(edfator) -C DFA torsion angle - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,ii - integer iatom(5) - double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) - double precision cwidth, cwidth2 - PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) - - edfator= 0.0d0 - enephi = 0.0d0 - enethe = 0.0d0 - gdfat(:,:) = 0.0d0 - -C START OF PHI ANGLE - do i=1, idfaphi - - aphi = 0.0d0 - iatom(1:5)=iphilis(1:5,i) - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) - -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - APHI(1)=TDOT/(DGI*DRIPP) - TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - APHI(2)=TDOT/(DGIP*DRIP3) - - ephi = 0.0d0 - tfphi1=0.0d0 - tfphi2=0.0d0 - scc=0.0d0 - - do j=1, iphinum(i) - DDPS1=APHI(1)-FPHI1(i,j) - DDPS2=APHI(2)-FPHI2(i,j) - - DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 - - if (dtmp.ge.15.0d0) then - ps_tmp = 0.0d0 - else - ps_tmp = dfaexp(idint(dtmp*1000)+1) - endif - - ephi=ephi+sccphi(i,j)*ps_tmp - - tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp - tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp - - scc=scc+sccphi(i,j) -C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), -C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) - ENDDO - - ephi=-ephi/scc*phi_inc*wwangle - tfphi1=tfphi1/scc*phi_inc*wwangle - tfphi2=tfphi2/scc*phi_inc*wwangle - - IF (ABS(EPHI).LT.1d-20) THEN - EPHI=0.0D0 - ENDIF - IF (ABS(TFPHI1).LT.1d-20) THEN - TFPHI1=0.0D0 - ENDIF - IF (ABS(TFPHI2).LT.1d-20) THEN - TFPHI2=0.0D0 - ENDIF - -C FORCE DIRECTION CALCULATION - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DRIPP) - - GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - DM2=GIRPP/(DGI**3*DRIPP) - DM3=GIRPP/(DGI*DRIPP**3) - - DM4=1.0d0/(DGIP*DRIP3) - - GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - DM5=GIRP3/(DGIP**3*DRIP3) - DM6=GIRP3/(DGIP*DRIP3**3) -C FIRST ATOM BY PHI1 - TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 - & +( GIZ* RIPY- GIY* RIPZ)*DM2 - TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 - & +( GIX* RIPZ- GIZ* RIPX)*DM2 - TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 - & +( GIY* RIPX- GIX* RIPY)*DM2 - TDX(1)=TDX(1)*TFPHI1 - TDY(1)=TDY(1)*TFPHI1 - TDZ(1)=TDZ(1)*TFPHI1 -C SECOND ATOM BY PHI1 - TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - TDX(2)=TDX(2)*TFPHI1 - TDY(2)=TDY(2)*TFPHI1 - TDZ(2)=TDZ(2)*TFPHI1 -C SECOND ATOM BY PHI2 - TDX(2)=TDX(2)+ - & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 - & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 - TDY(2)=TDY(2)+ - & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 - & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 - & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 -C THIRD ATOM BY PHI1 - TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 - & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 - TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 - & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 - TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 - & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 - TDX(3)=TDX(3)*TFPHI1 - TDY(3)=TDY(3)*TFPHI1 - TDZ(3)=TDZ(3)*TFPHI1 -C THIRD ATOM BY PHI2 - TDX(3)=TDX(3)+ - & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 - TDY(3)=TDY(3)+ - & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 -C FOURTH ATOM BY PHI1 - TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 - TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 - TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 -C FOURTH ATOM BY PHI2 - TDX(4)=TDX(4)+ - & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 - & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 - & + RIP3X*DM6)*TFPHI2 - TDY(4)=TDY(4)+ - & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 - & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 - & + RIP3Y*DM6)*TFPHI2 - TDZ(4)=TDZ(4)+ - & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 - & -( GIPX*RIPY-RIPX*GIPY)*DM5 - & + RIP3Z*DM6)*TFPHI2 -C FIFTH ATOM BY PHI2 - TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 - TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 - TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 -C END OF FORCE DIRECTION -c force calcuation - DO II=1,5 - gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) - gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) - gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) - ENDDO -c energy calculation - enephi = enephi + ephi -c end of single assignment statement - ENDDO -C END OF PHI RESTRAINT - -C START OF THETA ANGLE - do i=1, idfathe - - athe = 0.0d0 - iatom(1:5)=ithelis(1:5,i) - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y - GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z - GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ - ATHE(1)=TDOT/(DGI*DGIP) - TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ - ATHE(2)=TDOT/(DGIP*DGIPP) - - ETHE=0.0D0 - TFTHE1=0.0D0 - TFTHE2=0.0D0 - SCC=0.0D0 - TH_TMP=0.0d0 - - do j=1,ithenum(i) - ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) - ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) - dtmp= (ddth1**2+ddth2**2)/cwidth2 - if ( dtmp .ge. 15.0d0) then - th_tmp = 0.0d0 - else - th_tmp = dfaexp ( idint(dtmp*1000)+1 ) - end if - - ethe=ethe+sccthe(i,j)*th_tmp - - tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) - tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) - scc=scc+sccthe(i,j) -C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), -C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) - enddo - - ethe=-ethe/scc*the_inc*wwangle - tfthe1=tfthe1/scc*the_inc*wwangle - tfthe2=tfthe2/scc*the_inc*wwangle - - IF (ABS(ETHE).LT.TENM20) THEN - ETHE=0.0D0 - ENDIF - IF (ABS(TFTHE1).LT.TENM20) THEN - TFTHE1=0.0D0 - ENDIF - IF (ABS(TFTHE2).LT.TENM20) THEN - TFTHE2=0.0D0 - ENDIF - - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DGIP) - DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) - DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) - - DM4=1.0d0/(DGIP*DGIPP) - DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) - DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) - -C FIRST ATOM BY THETA1 - TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 - & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 - TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 - & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 - TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 - & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 -C SECOND ATOM BY THETA1 - TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 - TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 - TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 -C SECOND ATOM BY THETA2 - TDX(2)=TDX(2)+ - & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 - & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 - TDY(2)=TDY(2)+ - & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 - & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 - & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 -C THIRD ATOM BY THETA1 - TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 - & -(GIY*RIZ-GIZ*RIY)*DM2 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 - TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 - & -(GIZ*RIX-GIX*RIZ)*DM2 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 - TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 - & -(GIX*RIY-GIY*RIX)*DM2 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 -C THIRD ATOM BY THETA2 - TDX(3)=TDX(3)+ - & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 - & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 - TDY(3)=TDY(3)+ - & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 - & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 - & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 -C FOURTH ATOM BY THETA1 - TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 - & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 - TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 - & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 - TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 - & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 -C FOURTH ATOM BY THETA2 - TDX(4)=TDX(4)+ - & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 - & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 - & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 - TDY(4)=TDY(4)+ - & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 - & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 - & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 - TDZ(4)=TDZ(4)+ - & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 - & -(GIPX*RIPY-GIPY*RIPX)*DM5 - & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 -C FIFTH ATOM BY THETA2 - TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 - & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 - TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 - & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 - TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 - & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 -C !! END OF FORCE DIRECTION!!!! - DO II=1,5 - gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) - gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) - gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) - ENDDO -C energy calculation - enethe = enethe + ethe - ENDDO - - edfator = enephi + enethe - - RETURN - END - - subroutine edfan(edfanei) -C DFA neighboring CA restraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,imin - integer kshnum, n1atom - - double precision enenei,tmp_n - double precision pai,hpai - double precision jix,jiy,jiz,ndiff,snorm_nei - double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) - double precision dr,dr2,half,ntmp - - parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) - parameter(pai=3.14159265358979323846D0) - parameter(hpai=1.5707963267948966D0) - parameter(snorm_nei=0.886226925452758D0) - - edfanei = 0.0d0 - enenei = 0.0d0 - gdfan = 0.0d0 - -c print*, 's1:', s1(:) -c print*, 's2:', s2(:) - - do i=1, idfanei - - kshnum=kshell(i) - n1atom=ineilis(i) -C write(*,*) 'kshnum,n1atom:', kshnum, n1atom - - tmp_n=0.0d0 - ftmp=0.0d0 - dnei=0.0d0 - dist=0.0d0 - t1dx=0.0d0 - t1dy=0.0d0 - t1dz=0.0d0 - t2dx=0.0d0 - t2dy=0.0d0 - t2dz=0.0d0 - - do j = 1, nres - - if (n1atom.eq.j) cycle - - jix=c(1,j)-c(1,n1atom) - jiy=c(2,j)-c(2,n1atom) - jiz=c(3,j)-c(3,n1atom) - dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) - -c write(*,*) n1atom, j, dist - - if(kshnum.ne.1)then - if (dist.lt.s1(kshnum).and. - & dist.gt.s2(kshnum-1)) then - - tmp_n=tmp_n+1.0d0 - -c write(*,*) 'case1:',tmp_n - - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum)) then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case2:',tmp_n - ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp -c - elseif(dist.ge.s1(kshnum-1).and. - & dist.le.s2(kshnum-1)) then - dnei=(dist-s1(kshnum-1))/dr2*pai - tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) -c write(*,*) 'case3:',tmp_n - ftmp = hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - - elseif(kshnum.eq.1) then - - if(dist.lt.s1(kshnum))then - - tmp_n=tmp_n+1.0d0 -c write(*,*) 'case4:',tmp_n - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum))then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case5:',tmp_n - ftmp = -hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - endif - enddo - - scc=0.0d0 - enei=0.0d0 - tmp_fnei=0.0d0 - ndiff=0.0d0 - - do imin=1,ineinum(i) - - ndiff = tmp_n-fnei(i,imin) - dtmp = ndiff*ndiff - - if (dtmp.ge.15.0d0) then - ntmp = 0.0d0 - else - ntmp = dfaexp( idint(dtmp*1000) + 1 ) - end if - - enei=enei+sccnei(i,imin)*ntmp - tmp_fnei=tmp_fnei- - & sccnei(i,imin)*ntmp*ndiff*2.0d0 - scc=scc+sccnei(i,imin) - -c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, -c & fnei(i,imin),sccnei(i,imin),enei,scc - enddo - - enei=-enei/scc*snorm_nei*nei_inc*wwnei - tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei - - if (abs(enei).lt.1.0d-20)then - enei=0.0d0 - endif - if (abs(tmp_fnei).lt.1.0d-20) then - tmp_fnei=0.0d0 - endif - -c force calculation - t1dx=t1dx*tmp_fnei - t1dy=t1dy*tmp_fnei - t1dz=t1dz*tmp_fnei - - do j=1,nres - t2dx(j)=t2dx(j)*tmp_fnei - t2dy(j)=t2dy(j)*tmp_fnei - t2dz(j)=t2dz(j)*tmp_fnei - enddo - - gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx - gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy - gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz - - do j=1,nres - gdfan(1,j)=gdfan(1,j)+t2dx(j) - gdfan(2,j)=gdfan(2,j)+t2dy(j) - gdfan(3,j)=gdfan(3,j)+t2dz(j) - enddo -c energy calculation - - enenei=enenei+enei - - enddo - - edfanei=enenei - - return - end - - subroutine edfab(edfabeta) - - implicit real*8 (a-h,o-z) - - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - real*8 PAI - parameter(PAI=3.14159265358979323846D0) -C sheet variables - real*8 bx(maxres),by(maxres),bz(maxres) - real*8 vbet(maxres,maxres) - real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) - real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) - real*8 vbeta,vbetp,vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - real*8 dp45,dm45,w_beta - - common /sheca/ bx,by,bz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - common /shef/ shefx, shefy, shefz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta -C End of sheet variables - - integer i,j - double precision enebet - - enebet=0.0d0 - bx=0.0d0;by=0.0d0;bz=0.0d0 - shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 - - gdfab=0.0d0 - - do i=1,nres - bx(i)=c(1,i) - by(i)=c(2,i) - bz(i)=c(3,i) - enddo - - dca=0.25d0**2 - dshe=0.3d0**2 - ULHB=5.0D0 - ULDHB=5.0D0 - ULNEX=COS(60.0D0/180.0D0*PAI) - - DLHB=1.0D0 - DLDHB=1.0D0 - - DNEX=0.3D0**2 - - C00=COS((1.0D0+10.0D0/180.0D0)*PAI) - S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) - - W_BETA=0.5D0 - DP45=W_BETA - DM45=W_BETA - -C END OF INITIALIZATION - - nca=nres-1 - - call angvectors(nca) - call sheetforce(nca,wshet,dfaexp) - -c end of sheet energy and force - - do j=1,nres - shetfx(j)=shetfx(j)*beta_inc - shetfy(j)=shetfy(j)*beta_inc - shetfz(j)=shetfz(j)*beta_inc -c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) - enddo - - vbeta=vbeta*beta_inc - enebet=vbeta - edfabeta=enebet - - do j=1,nres - gdfab(1,j)=gdfab(1,j)-shetfx(j) - gdfab(2,j)=gdfab(2,j)-shetfy(j) - gdfab(3,j)=gdfab(3,j)-shetfz(j) - enddo - - return - end -C------------------------------------------------------------------------------- - subroutine angvectors(nca) -c implicit real*4(a-h,o-z) - implicit none - integer nca - integer maxca - parameter(maxca=800) - real*8 pai,zero - parameter(PAI=3.14159265358979323846D0,zero=0.0d0) - - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 cph(maxca),cth(maxca) - real*8 ulcos(maxca) - real*8 p,c - integer i, ip, ipp, ip3, j - real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) - real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz - real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz - real*8 cix, ciy, ciz, cipx, cipy, cipz - real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g - real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 - real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 - real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 - real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri - real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim - real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm - real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm - real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm - real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr - real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz - real*8 grpp,gx,gy,gz - real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz - real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 - integer inb,nmax,iselect - - common /sheca/ bx,by,bz - common /difvec/ rx, ry, rz - common /ulang/ ulcos - common /phys1/ inb,nmax,iselect - common /phys4/ p,c - common /kyori2/ dis - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - & apmmz,apm3x,apm3y,apm3z - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - & atmmz,atm3x,atm3y,atm3z - common /coscos/ cph,cth - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C------------------------------------------------------------------------------- -c write(*,*) 'inside angvectors' -C initialize - p=0.1d0 - c=1.0d0 - inb=nca - cph=zero; cth=zero; sth=zero - apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero - apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero - atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero - atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero - astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero - astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero - astm3z=zero -C end of initialize -C r[x,y,z] calc and distance calculation - rx=zero;ry=zero;rz=zero - - do i=1,inb - do j=1,inb - rx(i,j)=bx(j)-bx(i) - ry(i,j)=by(j)-by(i) - rz(i,j)=bz(j)-bz(i) - dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) -c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -c write(*,*) 'dis(i,j):',i,j,dis(i,j) - enddo - enddo -c end of r[x,y,z] calc -C cos calc - do i=1,inb-2 - ip=i+1 - ipp=i+2 - - if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then - ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) - $ +rz(i,ip)*rz(ip,ipp) - ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) - endif - enddo -c end of virtual bond angle -c write(*,*) 'inside angvectors1' - do i=1,inb-3 - ip=i+1 - ipp=i+2 - ip3=i+3 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - rippx=bx(ip3)-bx(ipp) - rippy=by(ip3)-by(ipp) - rippz=bz(ip3)-bz(ipp) - - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - gpx=ripy*rippz-ripz*rippy - gpy=ripz*rippx-ripx*rippz - gpz=ripx*rippy-ripy*rippx - gpcrp_x=gpy*ripz-gpz*ripy - gpcrp_y=gpz*ripx-gpx*ripz - gpcrp_z=gpx*ripy-gpy*ripx - d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) - gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy - & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy - - if(i.ge.2) then - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - drim=dis(i-1,i) - drim3=drim**3 - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - endif -c write(*,*) 'inside angvectors2' - if(i.ge.3) then - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - drimm=dis(i-2,i-1) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - endif - - if(i.ge.4) then - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - endif - - dri=dis(i,i+1) - drip=dis(i+1,i+2) - dripp=dis(i+2,i+3) - dri3=dri**3 - dg=sqrt(gx**2+gy**2+gz**2) - dgp=sqrt(gpx**2+gpy**2+gpz**2) - dg3=dg**3 - - ggp=gx*gpx+gy*gpy+gz*gpz - grpp=gx*rippx+gy*rippy+gz*rippz - - if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 - & .and.d_gpcrp.gt.0.0D0) then - cph(i)=grpp/dg/dripp - cth(i)=ggp/dg/dgp - sth(i)=gpcrp__g/d_gpcrp/dg - else -c - cph(i)=1.0D0 - cth(i)=1.0D0 - sth(i)=0.0D0 - endif - -c write(*,*) 'inside angvectors3' - - if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 - & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then - d10=1.0D0/(dg*dgp) - d11=ggp/(dg3*dgp) - d12=1.0D0/(dg*dripp) - d13=grpp/(dg3*dripp) - sd10=1.0D0/(d_gpcrp*dg) - sd11=gpcrp__g/(d_gpcrp*dg3) - else - d10=0.0D0 - d11=0.0D0 - d12=0.0D0 - d13=0.0D0 - sd10=0.0D0 - sd11=0.0D0 - endif - - atx(i)=(ripz*gpy-ripy*gpz)*d10 - & -(gy*ripz-gz*ripy)*d11 - aty(i)=(ripx*gpz-ripz*gpx)*d10 - & -(gz*ripx-gx*ripz)*d11 - atz(i)=(ripy*gpx-ripx*gpy)*d10 - & -(gx*ripy-gy*ripx)*d11 - astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz - & +ripy*gpy*ripx-gpx*ripz**2) - & -sd11*(gy*ripz-gz*ripy) - asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx - & -gpy*ripx**2+gpz*ripy*ripz) - & -sd11*(-gx*ripz+gz*ripx) - astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 - & -gpz*ripy**2+ripz*gpx*ripx) - & -sd11*(gx*ripy-gy*ripx) - apx(i)=(ripz*rippy-ripy*rippz)*d12 - & -(gy*ripz-gz*ripy)*d13 - apy(i)=(ripx*rippz-ripz*rippx)*d12 - & -(gz*ripx-gx*ripz)*d13 - apz(i)=(ripy*rippx-ripx*rippy)*d12 - & -(gx*ripy-gy*ripx)*d13 - - if(i.ge.2) then - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 - & .and.d_gcr3.gt.0.0D0) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - endif - - if(i.ge.3) then - if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif - -c write(*,*) 'inside angvectors4' - -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -c********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - - if(i.ge.4) then - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -c********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - endif - enddo -c******************************************************************************* - -c write(*,*) 'inside angvectors5' - - do i=inb-2,inb - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - drim=dis(i-1,i) - drimm=dis(i-2,i-1) - drim3=drim**3 - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -cc********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - - if(i.le.inb-1) then - ip=i+1 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - dri=dis(i,i+1) - dri3=dri**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - - if(dgm3.gt.0.0D0.and. - & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -cc********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - -c write(*,*) 'inside angvectors6' - - if(i.eq.inb-2) then - ipp=i+2 - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - dg=sqrt(gx**2+gy**2+gz**2) - dg3=dg**3 - drip=dis(i+1,i+2) - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - if(dgm3.gt.0.0D0.and. - & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 - & ) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** -c - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - - endif - enddo - - return - end -c END of angvectors -c------------------------------------------------------------------------------- -C--------------------------------------------------------------------------------- - subroutine sheetforce(nca,wshet,dfaexp) - implicit none -C JYLEE -c this should be matched with dfa.fcm - integer maxca - parameter(maxca=800) -cc********************************************************************** - integer nca - integer i,k - integer inb,nmax,iselect - - real*8 dfaexp(15001) - - real*8 vbeta,vbetp,vbetm - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) - real*8 vbet(maxca,maxca) - real*8 wshet(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - - inb=nca - do i=1,inb - shetfx(i)=0.0D0 - shetfy(i)=0.0D0 - shetfz(i)=0.0D0 - enddo - - do k=1,12 - do i=1,inb - shefx(i,k)=0.0D0 - shefy(i,k)=0.0D0 - shefz(i,k)=0.0D0 - enddo - enddo - - call sheetene(nca,wshet,dfaexp) - call sheetforce1 - - 887 format(a,1x,i6,3x,f12.8) - 888 format(a,1x,i4,1x,i4,3x,f12.8) - 889 format(a,1x,i4,3x,f12.8) - !write(2,*) 'coord : ' - do i=1,inb - !write(2,887) 'bx:',i,bx(i) - !write(2,887) 'by:',i,by(i) - !write(2,887) 'bz:',i,bz(i) - enddo - !write(2,*) 'After sheetforce1' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce5 - - !write(2,*) 'After sheetforce5' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce6 - - !write(2,*) 'After sheetforce6' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce11 - - !write(2,*) 'After sheetforce11' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce12 - - !write(2,*) 'After sheetforce12' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - do i=1,inb - do k=1,12 - shetfx(i)=shetfx(i)+shefx(i,k) - shetfy(i)=shetfy(i)+shefy(i,k) - shetfz(i)=shetfz(i)+shefz(i,k) - enddo - enddo - !write(2,*) 'Beta Finished' - do i=1,inb - !write(2,889) 'shetfx : ',i,shetfx(i) - !write(2,889) 'shetfy : ',i,shetfy(i) - !write(2,889) 'shetfz : ',i,shetfz(i) - enddo - - return - end -C end sheetforce -c------------------------------------------------------------------------------- - subroutine sheetene(nca,wshet,dfaexp) - implicit none - integer maxca - parameter(maxca=800) -cc****************************************************************************** - - real*8 dfaexp(15001) - real*8 dtmp1, dtmp2, dtmp3 - - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 ulcos(maxca) -cc********************************************************************** - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 wshet(maxca,maxca) - real*8 dp45, dm45, w_beta - real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb - integer nca - integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect - real*8 uum, uup - real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -cc********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth - - real*8 r_pair_mat(maxca,maxca) - common /beta_p/ r_pair_mat -C------------------------------------------------------------------------------- - r_pair_mat = 0.0d0 - do i=1,inb - do j=1,inb - r_pair_mat(i,j)=wshet(i,j) -c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) - enddo - enddo -c stop -c - vbeta=0.0D0 - vbetp=0.0D0 - vbetm=0.0D0 - - do i=1,inb-7 - do j=i+4,inb-3 - ip=i+1 - ipp=i+2 - jp=j+1 - jpp=j+2 -cc********************************************************************** - y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 - & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 - y1=-0.5d0*y1/dca - y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 - & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 - y2=-0.5d0*y2/dnex - y=y1+y2 - - yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb - - pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) - $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) - pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) - $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) - pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) - $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) - pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) - $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) - - yshe1=pin1(i,j)**2+pin2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pin3(i,j)**2+pin4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -C write(*,*) 'dis(i,j):',i,j,dis(i,j) -C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) -C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) -C write(*,*) 'pin1:',pin1(i,j) -C write(*,*) 'pin2:',pin2(i,j) -C write(*,*) 'pin3:',pin3(i,j) -C write(*,*) 'pin4:',pin4(i,j) - -C write(*,*) 'y:',y -C write(*,*) 'yy1:',yy1 -C write(*,*) 'yy2:',yy2 -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -c - - dtmp1 = y+yy1+yshe1 - dtmp2 = y+yy2+yshe2 - dtmp3 = y+yy1+yy2+yshe1+yshe2 - -C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 -C write(*,*)'2', y,yy1,yy2 -C write(*,*)'3', yshe1,yshe2 - - if (dtmp3.le.-15.0d0) then -c vbetap(i,j)=-dp45*exp(dtmp3) - vbetap(i,j)=0.0d0 - else - vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) - end if - - if (dtmp1.le.-15.0d0) then -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) - vbetap1(i,j)=0.0d0 - else - vbetap1(i,j)=-r_pair_mat(i+1,j+1) - $ *dfaexp(idint(-dtmp1*1000)+1) - end if - - if (dtmp2.le.-15.0d0) then -C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) - vbetap2(i,j)=0.0d0 - else - vbetap2(i,j)=-r_pair_mat(i+2,j+2) - $ *dfaexp(idint(-dtmp2*1000)+1) - end if - -c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) -c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) -! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) - - - yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb - - pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) - $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) - pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) - $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) - pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) - $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) - pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) - $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) - - yshe1=pina1(i,j)**2+pina2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pina3(i,j)**2+pina4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'pina1:',pina1(i,j) -C write(*,*) 'pina2:',pina2(i,j) -C write(*,*) 'pina3:',pina3(i,j) -C write(*,*) 'pina4:',pina4(i,j) -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -C write(*,*) 'dshe:',dshe - - dtmp3=y+yy1+yy2+yshe1+yshe2 - dtmp1=y+yy1+yshe1 - dtmp2=y+yy2+yshe2 - - if(dtmp3 .le. -15.0d0) then -c vbetam(i,j)=-dm45*exp(dtmp3) - vbetam(i,j)=0.0d0 - else - vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) - end if - - if(dtmp1 .le. -15.0d0) then -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) - vbetam1(i,j)=0.0d0 - else - vbetam1(i,j)=-r_pair_mat(i+1,j+2) - $ *dfaexp(idint(-dtmp1*1000)+1) - end if - - if(dtmp2.le.-15.0d0) then -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) - vbetam2(i,j)=0.0d0 - else - vbetam2(i,j)=-r_pair_mat(i+2,j+1) - $ *dfaexp(idint(-dtmp2*1000)+1) - end if - -c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) -! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) - - uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) - uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) - -c write(*,*) 'uup,uum:', uup, uum - -c uup=vbetap1(i,j)+vbetap2(i,j) -c uum=vbetam1(i,j)+vbetam2(i,j) - - vbet(i,j)=uup+uum - vbetp=vbetp+uup - vbetm=vbetm+uum - vbeta=vbeta+vbet(i,j) - -c write(*,*) 'uup,uum:',uup,uum -c write(*,*) 'vbetap(i,j):',vbetap(i,j) -c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -c write(*,*) 'vbetam(i,j):',vbetam(i,j) -c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -c write(*,*) 'uup:',uup -c write(*,*) 'uum:',uum -c write(*,*) 'vbetp:',vbetp -c write(*,*) 'vbetm:',vbetm -c write(*,*) 'vbet(i,j):',vbet(i,j) -c stop - - enddo - enddo - -! do i=1,inb-7 -! do j=i+4,inb-3 -! write(*,*) 'I,J:', i,j -! write(*,*) 'vbetap(i,j):',vbetap(i,j) -! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -! write(*,*) 'vbetam(i,j):',vbetam(i,j) -! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -! write(*,*) 'vbet(i,j):',vbet(i,j) -! enddo -! enddo - - return - end -c------------------------------------------------------------------------------- - subroutine sheetforce1 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 ulcos(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 w_beta,dp45, dm45 - real*8 vbeta, vbetp, vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect - - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - $ atmmz,atm3x,atm3y,atm3z - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - $ apmmz,apm3x,apm3y,apm3z - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -c c********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - $ astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C-------------------------------------------------------------------------------- -c local variables - integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp - real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 - real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 - real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 - real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 -C-------------------------------------------------------------------------------- - do i=4,inb-4 - im3=i-3 - imm=i-2 - im=i-1 - c1=(cth(im3)*c00+sth(im3)*s00-1)/dca - v1=0.0D0 - do j=i+1,inb-3 - v1=v1+vbet(im3,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - dmm=cc1/(dis(imm,im)*dis(im,i)) - dmm__=cc1*ulcos(imm)/dis(im,i)**2 - fx=rx(imm,im)*dmm-rx(im,i)*dmm__ - fy=ry(imm,im)*dmm-ry(im,i)*dmm__ - fz=rz(imm,im)*dmm-rz(im,i)*dmm__ - fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 - fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 - fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 - shefx(i,1)=fx*v1 - shefy(i,1)=fy*v1 - shefz(i,1)=fz*v1 - enddo - - do i=3,inb-5 - imm=i-2 - im=i-1 - ip=i+1 - c2=(cth(imm)*c00+sth(imm)*s00-1)/dca - v2=0.0D0 - do j=i+2,inb-3 - v2=v2+vbet(imm,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - cc2=(ulcos(im)-ulnex)/dnex - dmm1=cc1/(dis(imm,im)*dis(im,i)) - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm1__=cc1*ulcos(imm)/dis(im,i)**2 - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 -cc********************************************************************** - fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 - fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 - fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 - fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 - fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 - fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 - shefx(i,2)=fx*v2 - shefy(i,2)=fy*v2 - shefz(i,2)=fz*v2 - enddo - do i=2,inb-6 - im=i-1 - ip=i+1 - ipp=i+2 - c3=(cth(im)*c00+sth(im)*s00-1)/dca - v3=0.0D0 - do j=i+3,inb-3 - v3=v3+vbet(im,j) - enddo - cc2=(ulcos(im)-ulnex)/dnex - cc3=(ulcos(i)-ulnex)/dnex - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ - fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 - fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 - fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 - shefx(i,3)=fx*v3 - shefy(i,3)=fy*v3 - shefz(i,3)=fz*v3 - enddo - do i=1,inb-7 - ip=i+1 - ipp=i+2 - c4=(cth(i)*c00+sth(i)*s00-1)/dca - v4=0.0D0 - do j=i+4,inb-3 - v4=v4+vbet(i,j) - enddo - cc3=(ulcos(i)-ulnex)/dnex - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ - fx=fx+(atx(i)*c00+astx(i)*s00)*c4 - fy=fy+(aty(i)*c00+asty(i)*s00)*c4 - fz=fz+(atz(i)*c00+astz(i)*s00)*c4 - shefx(i,4)=fx*v4 - shefy(i,4)=fy*v4 - shefz(i,4)=fz*v4 - enddo - do j=8,inb - jm3=j-3 - jmm=j-2 - jm=j-1 - c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca - v7=0.0D0 - do i=1,j-7 - v7=v7+vbet(i,jm3) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - dmm=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 - fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ - fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ - fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ - fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 - fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 - fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 - shefx(j,7)=fx*v7 - shefy(j,7)=fy*v7 - shefz(j,7)=fz*v7 - enddo - do j=7,inb-1 - jm=j-1 - jmm=j-2 - jp=j+1 - c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca - v8=0.0D0 - do i=1,j-6 - v8=v8+vbet(i,jmm) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - cc8=(ulcos(jm)-ulnex)/dnex - dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 - fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 - fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 - fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 - fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 - fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 - shefx(j,8)=fx*v8 - shefy(j,8)=fy*v8 - shefz(j,8)=fz*v8 - enddo - - do j=6,inb-2 - jm=j-1 - jp=j+1 - jpp=j+2 - c9=(cth(jm)*c00+sth(jm)*s00-1)/dca - v9=0.0D0 - do i=1,j-5 - v9=v9+vbet(i,jm) - enddo - cc8=(ulcos(jm)-ulnex)/dnex - cc9=(ulcos(j)-ulnex)/dnex - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ - fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 - fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 - fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 - shefx(j,9)=fx*v9 - shefy(j,9)=fy*v9 - shefz(j,9)=fz*v9 - enddo - - do j=5,inb-3 - jp=j+1 - jpp=j+2 - c10=(cth(j)*c00+sth(j)*s00-1)/dca - v10=0.0D0 - do i=1,j-4 - v10=v10+vbet(i,j) - enddo - cc9=(ulcos(j)-ulnex)/dnex - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ - fx=fx+(atx(j)*c00+astx(j)*s00)*c10 - fy=fy+(aty(j)*c00+asty(j)*s00)*c10 - fz=fz+(atz(j)*c00+astz(j)*s00)*c10 - shefx(j,10)=fx*v10 - shefy(j,10)=fy*v10 - shefz(j,10)=fz*v10 - enddo - - return - end -c---------------------------------------------------------------------------- - subroutine sheetforce5 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -c******************************************************************************** -c local variables - integer i,imm,im,jp,jpp,j - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z - real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b -c******************************************************************************** - do i=3,inb-5 - imm=i-2 - im=i-1 - do j=i+2,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jpp)-ulhb)/dlhb - y1x=rx(jpp,i)/dis(i,jpp) - y1y=ry(jpp,i)/dis(i,jpp) - y1z=rz(jpp,i)/dis(i,jpp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(im,jp)*dis(im,i)) - yyy3=pin1(imm,j)/(dis(im,i)**2) - yy3=-pin1(imm,j)/dshe - y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 - y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 - y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 - - yy44=1.0D0/(dis(i,jpp)*dis(im,i)) - yyy4a=pin3(imm,j)/(dis(i,jpp)**2) - yyy4b=pin3(imm,j)/(dis(im,i)**2) - yy4=-pin3(imm,j)/dshe - y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) - $ -yyy4b*rx(im,i))*yy4 - y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) - $ -yyy4b*ry(im,i))*yy4 - y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) - $ -yyy4b*rz(im,i))*yy4 - - - yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy5=pin4(imm,j)/(dis(i,jpp)**2) - yy5=-pin4(imm,j)/dshe - y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 - y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 - y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) - $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) - $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) - $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - - yy6=-(dis(i,jp)-uldhb)/dldhb - y6x=rx(jp,i)/dis(i,jp) - y6y=ry(jp,i)/dis(i,jp) - y6z=rz(jp,i)/dis(i,jp) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(im,jpp)*dis(im,i)) - yyy8=pina1(imm,j)/(dis(im,i)**2) - yy8=-pina1(imm,j)/dshe - y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 - y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 - y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 - - yy99=1.0D0/(dis(jp,i)*dis(im,i)) - yyy9a=pina3(imm,j)/(dis(jp,i)**2) - yyy9b=pina3(imm,j)/(dis(im,i)**2) - yy9=-pina3(imm,j)/dshe - y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) - $ -yyy9b*rx(im,i))*yy9 - y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) - $ -yyy9b*ry(im,i))*yy9 - y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) - $ -yyy9b*rz(im,i))*yy9 - - yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) - yyy10=pina4(imm,j)/(dis(jp,i)**2) - yy10=-pina4(imm,j)/dshe - y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 - y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 - y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) - $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) - $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) - $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - - enddo - enddo - - return - end -c--------------------------------------------------------------------------c - subroutine sheetforce6 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer i,imm,im,jp,jpp,j,ip - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 - real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b -C******************************************************************************** - do i=2,inb-6 - ip=i+1 - im=i-1 - do j=i+3,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jp)-ulhb)/dlhb - y1x=rx(jp,i)/dis(i,jp) - y1y=ry(jp,i)/dis(i,jp) - y1z=rz(jp,i)/dis(i,jp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(i,jp)*dis(i,ip)) - yyy3a=pin1(im,j)/(dis(i,jp)**2) - yyy3b=pin1(im,j)/(dis(i,ip)**2) - yy3=-pin1(im,j)/dshe - y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) - $ +yyy3b*rx(i,ip))*yy3 - y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) - $ +yyy3b*ry(i,ip))*yy3 - y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) - $ +yyy3b*rz(i,ip))*yy3 - - yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) - yyy4=pin2(im,j)/(dis(i,jp)**2) - yy4=-pin2(im,j)/dshe - y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 - y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 - y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 - - yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) - yyy5=pin3(im,j)/(dis(i,ip)**2) - yy5=-pin3(im,j)/dshe - y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 - y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 - y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) - $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) - $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) - $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) - - yy6=-(dis(jpp,i)-uldhb)/dldhb - y6x=rx(jpp,i)/dis(jpp,i) - y6y=ry(jpp,i)/dis(jpp,i) - y6z=rz(jpp,i)/dis(jpp,i) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) - yyy8a=pina1(im,j)/(dis(i,jpp)**2) - yyy8b=pina1(im,j)/(dis(i,ip)**2) - yy8=-pina1(im,j)/dshe - y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) - $ +yyy8b*rx(i,ip))*yy8 - y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) - $ +yyy8b*ry(i,ip))*yy8 - y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) - $ +yyy8b*rz(i,ip))*yy8 - - yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy9=pina2(im,j)/(dis(i,jpp)**2) - yy9=-pina2(im,j)/dshe - y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 - y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 - y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 - - yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) - yyy10=pina3(im,j)/(dis(i,ip)**2) - yy10=-pina3(im,j)/dshe - y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 - y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 - y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) - $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) - $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) - $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce11 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -C******************************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 - real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 -C******************************************************************************** - - do j=7,inb-1 - jm=j-1 - jmm=j-2 - do i=1,j-6 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ipp,j)-ulhb)/dlhb - y1x=rx(ipp,j)/dis(ipp,j) - y1y=ry(ipp,j)/dis(ipp,j) - y1z=rz(ipp,j)/dis(ipp,j) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) - yyy3=pin2(i,jmm)/(dis(jm,j)**2) - yy3=-pin2(i,jmm)/dshe - y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 - y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 - y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 - - yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) - yyy4=pin3(i,jmm)/(dis(ipp,j)**2) - yy4=-pin3(i,jmm)/dshe - y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 - y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 - y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 - - yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) - yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) - yyy5b=pin4(i,jmm)/(dis(jm,j)**2) - yy5=-pin4(i,jmm)/dshe - y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) - $ -yyy5b*rx(jm,j))*yy5 - y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) - $ -yyy5b*ry(jm,j))*yy5 - y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) - $ -yyy5b*rz(jm,j))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) - $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) - $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) - $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - - yy6=-(dis(ip,j)-uldhb)/dldhb - y6x=rx(ip,j)/dis(ip,j) - y6y=ry(ip,j)/dis(ip,j) - y6z=rz(ip,j)/dis(ip,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy8=pina1(i,jmm)/(dis(ip,j)**2) - yy8=-pina1(i,jmm)/dshe - y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 - y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 - y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 - - yy99=1.0D0/(dis(ip,j)*dis(jm,j)) - yyy9a=pina2(i,jmm)/(dis(ip,j)**2) - yyy9b=pina2(i,jmm)/(dis(jm,j)**2) - yy9=-pina2(i,jmm)/dshe - y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) - $ -yyy9b*rx(jm,j))*yy9 - y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) - $ -yyy9b*ry(jm,j))*yy9 - y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) - $ -yyy9b*rz(jm,j))*yy9 - - yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) - yyy10=pina4(i,jmm)/(dis(jm,j)**2) - yy10=-pina4(i,jmm)/dshe - y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 - y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 - y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) - $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) - $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) - $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce12 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp,jp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 -!c*************************************************************************c - do j=6,inb-2 - jp=j+1 - jm=j-1 - do i=1,j-5 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ip,j)-ulhb)/dlhb - y1x=rx(ip,j)/dis(ip,j) - y1y=ry(ip,j)/dis(ip,j) - y1z=rz(ip,j)/dis(ip,j) - y11x=y1x*yy1 - y11y=y1y*yy1 - y11z=y1z*yy1 - - yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy3=pin1(i,jm)/(dis(ip,j)**2) - yy3=-pin1(i,jm)/dshe - y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 - y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 - y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 - yy44=1.0D0/(dis(ip,j)*dis(j,jp)) - - yyy4a=pin2(i,jm)/(dis(ip,j)**2) - yyy4b=pin2(i,jm)/(dis(j,jp)**2) - yy4=-pin2(i,jm)/dshe - y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) - $ +yyy4b*rx(j,jp))*yy4 - y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) - $ +yyy4b*ry(j,jp))*yy4 - y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) - $ +yyy4b*rz(j,jp))*yy4 - - yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) - yyy5=pin4(i,jm)/(dis(j,jp)**2) - yy5=-pin4(i,jm)/dshe - y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 - y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 - y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) - $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) - $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) - $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - -! shefx(j,12)=shefx(j,12) -! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) -! shefy(j,12)=shefy(j,12) -! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) -! shefz(j,12)=shefz(j,12) -! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - - yy6=-(dis(ipp,j)-uldhb)/dldhb - y6x=rx(ipp,j)/dis(ipp,j) - y6y=ry(ipp,j)/dis(ipp,j) - y6z=rz(ipp,j)/dis(ipp,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) - yyy8=pina2(i,jm)/(dis(j,jp)**2) - yy8=-pina2(i,jm)/dshe - y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 - y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 - y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 - - yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) - yyy9=pina3(i,jm)/(dis(j,ipp)**2) - yy9=-pina3(i,jm)/dshe - y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 - y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 - y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 - - yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) - yyy10a=pina4(i,jm)/(dis(j,ipp)**2) - yyy10b=pina4(i,jm)/(dis(j,jp)**2) - yy10=-pina4(i,jm)/dshe - y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) - $ +yyy10b*rx(j,jp))*yy10 - y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) - $ +yyy10b*ry(j,jp))*yy10 - y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) - $ +yyy10b*rz(j,jp))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) - $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) - $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) - $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) - - ENDDO - ENDDO - - RETURN - END -C=============================================================================== diff --git a/source/unres/src_CSA/dfa__.F b/source/unres/src_CSA/dfa__.F deleted file mode 100644 index 3b6d72c..0000000 --- a/source/unres/src_CSA/dfa__.F +++ /dev/null @@ -1,3123 +0,0 @@ - subroutine init_dfa_vars - - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.DFA' - - integer ii - -C Number of restraints - idisnum = 0 - iphinum = 0 - ithenum = 0 - ineinum = 0 - - idislis = 0 - iphilis = 0 - ithelis = 0 - ineilis = 0 - jneilis = 0 - jneinum = 0 - kshell = 0 - fnei = 0 -C For beta - nca = 0 - icaidx = 0 - -C real variables -CC WEIGHTS for each min - sccdist = 0.0d0 - fdist = 0.0d0 - sccphi = 0.0d0 - sccthe = 0.0d0 - sccnei = 0.0d0 - fphi1 = 0.0d0 - fphi2 = 0.0d0 - fthe1 = 0.0d0 - fthe2 = 0.0d0 -C energies - edfatot = 0.0d0 - edfadis = 0.0d0 - edfaphi = 0.0d0 - edfathe = 0.0d0 - edfanei = 0.0d0 - edfabet = 0.0d0 -C weights for each E term -C these should be identical with - dis_inc = 0.0d0 - phi_inc = 0.0d0 - the_inc = 0.0d0 - nei_inc = 0.0d0 - beta_inc = 0.0d0 - wshet = 0.0d0 -C precalculate exp table! -c dfaexp = 0.0d0 -c do ii = 1, 15001 -c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) -c end do - - ishiftca=nnt-1 - ilastca=nct - - print *,'ishiftca=',ishiftca,'ilastca=',ilastca - - return - end - - - subroutine read_dfa_info -C -C read fragment informations -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DFA' - - -C NOTE THAT FILENAMES are FIXED, CURRENTLY!! -C THIS SHOULD BE MODIFIED!! - - character*320 buffer - integer iodfa - parameter(iodfa=89) - - integer i, j, nval - integer ica1, ica2,ica3,ica4,ica5 - integer ishell, inca, itmp,iitmp - double precision wtmp -C -C READ DISTANCE -C - open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) - goto 34 - 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 34 continue - write(iout,'(a)') 'dist_dfa.dat is opened!' -C read title - read(iodfa, '(a)') buffer -C read number of restraints - read(iodfa, '(i)') IDFADIS - read(iodfa, *) dis_inc - do i=1, idfadis - read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval - - idisnum(i)=nval - idislis(1,i)=ica1 - idislis(2,i)=ica2 - - do j=1, nval - read(iodfa,*) tmp - fdist(i,j) = tmp - enddo - - do j=1, nval - read(iodfa,*) tmp - sccdist(i,j) = tmp - enddo - - enddo - close(iodfa) - -C READ ANGLE RESTRAINTS -C PHI RESTRAINTS - open(iodfa, file='phi_dfa.dat',status='old',err=35) - goto 36 - 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - - 36 continue - write(iout,'(a)') 'phi_dfa.dat is opened!' - -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFAPHI - read(iodfa,*) phi_inc - do i=1, idfaphi - read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - iphinum(i)=nval - - iphilis(1,i)=ica1 - iphilis(2,i)=ica2 - iphilis(3,i)=ica3 - iphilis(4,i)=ica4 - iphilis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fphi1(i,j) = tmp1 - fphi2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccphi(i,j) = tmp - enddo - - enddo - close(iodfa) - -C THETA RESTRAINTS - open(iodfa, file='theta_dfa.dat',status='old',err=41) - goto 42 - 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 42 continue - write(iout,'(a)') 'theta_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') IDFATHE - read(iodfa,*) the_inc - - do i=1, idfathe - read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - ithenum(i)=nval - - ithelis(1,i)=ica1 - ithelis(2,i)=ica2 - ithelis(3,i)=ica3 - ithelis(4,i)=ica4 - ithelis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fthe1(i,j) = tmp1 - fthe2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccthe(i,j) = tmp - enddo - - enddo - close(iodfa) -C END of READING ANGLE RESTRAINT! - -C NUMBER OF NEIGHBOR CAs - open(iodfa,file='nei_dfa.dat',status='old',err=37) - goto 38 - 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' - stop - 38 continue - write(iout,'(a)') 'nei_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, '(i)') idfanei - read(iodfa,*) nei_inc - - do i=1, idfanei - read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval - - ineilis(i)=ica1 - kshell(i)=ishell - ineinum(i)=nval - - do j=1, nval - read(iodfa,*) inca - fnei(i,j) = inca -C write(*,*) 'READ NEI:',i,j,fnei(i,j) - enddo - - do j=1, nval - read(iodfa,*) tmp - sccnei(i,j) = tmp - enddo - - enddo - close(iodfa) -C END OF NEIGHBORING CA - -C READ BETA RESTRAINT - open(iodfa, file='beta_dfa.dat',status='old',err=39) - goto 40 - 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' - stop - 40 continue - write(iout,'(a)') 'beta_dfa.dat is opened!' - - read(iodfa,'(a)') buffer - read(iodfa,'(i)') itmp - read(iodfa,*) beta_inc - - do i=1,itmp - read(iodfa,*) ica1, iitmp - do j=1,itmp - read(iodfa,*) wtmp - wshet(i,j) = wtmp -c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) - enddo - enddo - - close(iodfa) -C END OF BETA RESTRAINT - - return - END - - subroutine edfad(edfadis) - - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - double precision edfadis - integer i, iatm1, iatm2,idiff - double precision ckk, sckk,dist,texp - double precision jix,jiy,jiz,ep,fp,scc - - gdfad=0.0d0 - - do i=1, idfadis - - iatm1=idislis(1,i)+ishiftca - iatm2=idislis(2,i)+ishiftca - idiff = abs(iatm1-iatm2) - - JIX=c(1,iatm2)-c(1,iatm1) - JIY=c(2,iatm2)-c(2,iatm1) - JIZ=c(3,iatm2)-c(3,iatm1) - DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) - - ckk=ck(idiff) - sckk=sck(idiff) - - scc = 0.0d0 - ep = 0.0d0 - fp = 0.0d0 - - do j=1,idisnum(i) - - dd = dist-fdist(i,j) - dtmp = dd*dd/ckk - if (dtmp.ge.15.0d0) then - texp = 0.0d0 - else -c texp = dfaexp( idint(dtmp*1000)+1 )/sckk - texp = exp(-dtmp)/sckk - endif - - ep=ep+sccdist(i,j)*texp - fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk - scc=scc+sccdist(i,j) -C write(*,'(2i8,6f12.5)') i, j, dist, -C & fdist(i,j), ep, fp, sccdist(i,j), scc - - enddo - - ep = -ep/scc - fp = fp/scc - - -c IF(ABS(EP).lt.1.0d-20)THEN -c EP=0.0D0 -c ENDIF -c IF (ABS(FP).lt.1.0d-20) THEN -c FP=0.0D0 -c ENDIF - - edfadis=edfadis+ep*dis_inc*wwdist - - gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist - - gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist - - enddo - - return - end - - subroutine edfat(edfator) -C DFA torsion angle - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,ii,iii - integer iatom(5) - double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) - double precision cwidth, cwidth2 - PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) - - edfator= 0.0d0 - enephi = 0.0d0 - enethe = 0.0d0 - gdfat(:,:) = 0.0d0 - -C START OF PHI ANGLE - do i=1, idfaphi - - aphi = 0.0d0 - do iii=1,5 - iatom(iii)=iphilis(iii,i)+ishiftca - enddo - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) - -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - APHI(1)=TDOT/(DGI*DRIPP) - TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - APHI(2)=TDOT/(DGIP*DRIP3) - - ephi = 0.0d0 - tfphi1=0.0d0 - tfphi2=0.0d0 - scc=0.0d0 - - do j=1, iphinum(i) - DDPS1=APHI(1)-FPHI1(i,j) - DDPS2=APHI(2)-FPHI2(i,j) - - DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 - - if (dtmp.ge.15.0d0) then - ps_tmp = 0.0d0 - else -c ps_tmp = dfaexp(idint(dtmp*1000)+1) - ps_tmp = exp(-dtmp) - endif - - ephi=ephi+sccphi(i,j)*ps_tmp - - tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp - tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp - - scc=scc+sccphi(i,j) -C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), -C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) - ENDDO - - ephi=-ephi/scc*phi_inc*wwangle - tfphi1=tfphi1/scc*phi_inc*wwangle - tfphi2=tfphi2/scc*phi_inc*wwangle - - IF (ABS(EPHI).LT.1d-20) THEN - EPHI=0.0D0 - ENDIF - IF (ABS(TFPHI1).LT.1d-20) THEN - TFPHI1=0.0D0 - ENDIF - IF (ABS(TFPHI2).LT.1d-20) THEN - TFPHI2=0.0D0 - ENDIF - -C FORCE DIRECTION CALCULATION - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DRIPP) - - GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - DM2=GIRPP/(DGI**3*DRIPP) - DM3=GIRPP/(DGI*DRIPP**3) - - DM4=1.0d0/(DGIP*DRIP3) - - GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - DM5=GIRP3/(DGIP**3*DRIP3) - DM6=GIRP3/(DGIP*DRIP3**3) -C FIRST ATOM BY PHI1 - TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 - & +( GIZ* RIPY- GIY* RIPZ)*DM2 - TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 - & +( GIX* RIPZ- GIZ* RIPX)*DM2 - TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 - & +( GIY* RIPX- GIX* RIPY)*DM2 - TDX(1)=TDX(1)*TFPHI1 - TDY(1)=TDY(1)*TFPHI1 - TDZ(1)=TDZ(1)*TFPHI1 -C SECOND ATOM BY PHI1 - TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - TDX(2)=TDX(2)*TFPHI1 - TDY(2)=TDY(2)*TFPHI1 - TDZ(2)=TDZ(2)*TFPHI1 -C SECOND ATOM BY PHI2 - TDX(2)=TDX(2)+ - & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 - & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 - TDY(2)=TDY(2)+ - & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 - & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 - & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 -C THIRD ATOM BY PHI1 - TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 - & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 - TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 - & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 - TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 - & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 - TDX(3)=TDX(3)*TFPHI1 - TDY(3)=TDY(3)*TFPHI1 - TDZ(3)=TDZ(3)*TFPHI1 -C THIRD ATOM BY PHI2 - TDX(3)=TDX(3)+ - & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 - TDY(3)=TDY(3)+ - & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 -C FOURTH ATOM BY PHI1 - TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 - TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 - TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 -C FOURTH ATOM BY PHI2 - TDX(4)=TDX(4)+ - & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 - & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 - & + RIP3X*DM6)*TFPHI2 - TDY(4)=TDY(4)+ - & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 - & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 - & + RIP3Y*DM6)*TFPHI2 - TDZ(4)=TDZ(4)+ - & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 - & -( GIPX*RIPY-RIPX*GIPY)*DM5 - & + RIP3Z*DM6)*TFPHI2 -C FIFTH ATOM BY PHI2 - TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 - TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 - TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 -C END OF FORCE DIRECTION -c force calcuation - DO II=1,5 - gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) - gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) - gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) - ENDDO -c energy calculation - enephi = enephi + ephi -c end of single assignment statement - ENDDO -C END OF PHI RESTRAINT - -C START OF THETA ANGLE - do i=1, idfathe - - athe = 0.0d0 - do iii=1,5 - iatom(iii)=ithelis(iii,i)+ishiftca - enddo - - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y - GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z - GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ - ATHE(1)=TDOT/(DGI*DGIP) - TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ - ATHE(2)=TDOT/(DGIP*DGIPP) - - ETHE=0.0D0 - TFTHE1=0.0D0 - TFTHE2=0.0D0 - SCC=0.0D0 - TH_TMP=0.0d0 - - do j=1,ithenum(i) - ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) - ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) - dtmp= (ddth1**2+ddth2**2)/cwidth2 - if ( dtmp .ge. 15.0d0) then - th_tmp = 0.0d0 - else -c th_tmp = dfaexp ( idint(dtmp*1000)+1 ) - th_tmp = exp(-dtmp) - end if - - ethe=ethe+sccthe(i,j)*th_tmp - - tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) - tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) - scc=scc+sccthe(i,j) -C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), -C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) - enddo - - ethe=-ethe/scc*the_inc*wwangle - tfthe1=tfthe1/scc*the_inc*wwangle - tfthe2=tfthe2/scc*the_inc*wwangle - - IF (ABS(ETHE).LT.TENM20) THEN - ETHE=0.0D0 - ENDIF - IF (ABS(TFTHE1).LT.TENM20) THEN - TFTHE1=0.0D0 - ENDIF - IF (ABS(TFTHE2).LT.TENM20) THEN - TFTHE2=0.0D0 - ENDIF - - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DGIP) - DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) - DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) - - DM4=1.0d0/(DGIP*DGIPP) - DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) - DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) - -C FIRST ATOM BY THETA1 - TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 - & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 - TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 - & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 - TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 - & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 -C SECOND ATOM BY THETA1 - TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 - TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 - TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 -C SECOND ATOM BY THETA2 - TDX(2)=TDX(2)+ - & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 - & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 - TDY(2)=TDY(2)+ - & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 - & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 - & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 -C THIRD ATOM BY THETA1 - TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 - & -(GIY*RIZ-GIZ*RIY)*DM2 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 - TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 - & -(GIZ*RIX-GIX*RIZ)*DM2 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 - TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 - & -(GIX*RIY-GIY*RIX)*DM2 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 -C THIRD ATOM BY THETA2 - TDX(3)=TDX(3)+ - & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 - & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 - TDY(3)=TDY(3)+ - & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 - & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 - & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 -C FOURTH ATOM BY THETA1 - TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 - & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 - TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 - & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 - TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 - & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 -C FOURTH ATOM BY THETA2 - TDX(4)=TDX(4)+ - & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 - & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 - & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 - TDY(4)=TDY(4)+ - & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 - & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 - & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 - TDZ(4)=TDZ(4)+ - & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 - & -(GIPX*RIPY-GIPY*RIPX)*DM5 - & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 -C FIFTH ATOM BY THETA2 - TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 - & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 - TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 - & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 - TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 - & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 -C !! END OF FORCE DIRECTION!!!! - DO II=1,5 - gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) - gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) - gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) - ENDDO -C energy calculation - enethe = enethe + ethe - ENDDO - - edfator = enephi + enethe - - RETURN - END - - subroutine edfan(edfanei) -C DFA neighboring CA restraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,imin - integer kshnum, n1atom - - double precision enenei,tmp_n - double precision pai,hpai - double precision jix,jiy,jiz,ndiff,snorm_nei - double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) - double precision dr,dr2,half,ntmp,dtmp - - parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) - parameter(pai=3.14159265358979323846D0) - parameter(hpai=1.5707963267948966D0) - parameter(snorm_nei=0.886226925452758D0) - - edfanei = 0.0d0 - enenei = 0.0d0 - gdfan = 0.0d0 - -c print*, 's1:', s1(:) -c print*, 's2:', s2(:) - - do i=1, idfanei - - kshnum=kshell(i) - n1atom=ineilis(i)+ishiftca -C write(*,*) 'kshnum,n1atom:', kshnum, n1atom - - tmp_n=0.0d0 - ftmp=0.0d0 - dnei=0.0d0 - dist=0.0d0 - t1dx=0.0d0 - t1dy=0.0d0 - t1dz=0.0d0 - t2dx=0.0d0 - t2dy=0.0d0 - t2dz=0.0d0 - - do j = ishiftca+1, ilastca - - if (n1atom.eq.j) cycle - - jix=c(1,j)-c(1,n1atom) - jiy=c(2,j)-c(2,n1atom) - jiz=c(3,j)-c(3,n1atom) - dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) - -c write(*,*) n1atom, j, dist - - if(kshnum.ne.1)then - if (dist.lt.s1(kshnum).and. - & dist.gt.s2(kshnum-1)) then - - tmp_n=tmp_n+1.0d0 - -c write(*,*) 'case1:',tmp_n - - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum)) then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case2:',tmp_n - ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp -c - elseif(dist.ge.s1(kshnum-1).and. - & dist.le.s2(kshnum-1)) then - dnei=(dist-s1(kshnum-1))/dr2*pai - tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) -c write(*,*) 'case3:',tmp_n - ftmp = hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - - elseif(kshnum.eq.1) then - - if(dist.lt.s1(kshnum))then - - tmp_n=tmp_n+1.0d0 -c write(*,*) 'case4:',tmp_n - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum))then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case5:',tmp_n - ftmp = -hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - endif - enddo - - scc=0.0d0 - enei=0.0d0 - tmp_fnei=0.0d0 - ndiff=0.0d0 - - do imin=1,ineinum(i) - - ndiff = tmp_n-fnei(i,imin) - dtmp = ndiff*ndiff - - if (dtmp.ge.15.0d0) then - ntmp = 0.0d0 - else -c ntmp = dfaexp( idint(dtmp*1000) + 1 ) - ntmp = exp(-dtmp) - end if - - enei=enei+sccnei(i,imin)*ntmp - tmp_fnei=tmp_fnei- - & sccnei(i,imin)*ntmp*ndiff*2.0d0 - scc=scc+sccnei(i,imin) - -c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, -c & fnei(i,imin),sccnei(i,imin),enei,scc - enddo - - enei=-enei/scc*snorm_nei*nei_inc*wwnei - tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei - -c if (abs(enei).lt.1.0d-20)then -c enei=0.0d0 -c endif -c if (abs(tmp_fnei).lt.1.0d-20) then -c tmp_fnei=0.0d0 -c endif - -c force calculation - t1dx=t1dx*tmp_fnei - t1dy=t1dy*tmp_fnei - t1dz=t1dz*tmp_fnei - - do j=ishiftca+1,ilastca - t2dx(j)=t2dx(j)*tmp_fnei - t2dy(j)=t2dy(j)*tmp_fnei - t2dz(j)=t2dz(j)*tmp_fnei - enddo - - gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx - gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy - gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz - - do j=ishiftca+1,ilastca - gdfan(1,j)=gdfan(1,j)+t2dx(j) - gdfan(2,j)=gdfan(2,j)+t2dy(j) - gdfan(3,j)=gdfan(3,j)+t2dz(j) - enddo -c energy calculation - - enenei=enenei+enei - - enddo - - edfanei=enenei - - return - end - - subroutine edfab(edfabeta) - - implicit real*8 (a-h,o-z) - - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - real*8 PAI - parameter(PAI=3.14159265358979323846D0) -C sheet variables - real*8 bx(maxres),by(maxres),bz(maxres) - real*8 vbet(maxres,maxres) - real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) - real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) - real*8 vbeta,vbetp,vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - real*8 dp45,dm45,w_beta - - common /sheca/ bx,by,bz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - common /shef/ shefx, shefy, shefz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta -C End of sheet variables - - integer i,j - double precision enebet - - enebet=0.0d0 - bx=0.0d0;by=0.0d0;bz=0.0d0 - shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 - - gdfab=0.0d0 - - do i=ishiftca+1,ilastca - bx(i-ishiftca)=c(1,i) - by(i-ishiftca)=c(2,i) - bz(i-ishiftca)=c(3,i) - enddo - - dca=0.25d0**2 - dshe=0.3d0**2 - ULHB=5.0D0 - ULDHB=5.0D0 - ULNEX=COS(60.0D0/180.0D0*PAI) - - DLHB=1.0D0 - DLDHB=1.0D0 - - DNEX=0.3D0**2 - - C00=COS((1.0D0+10.0D0/180.0D0)*PAI) - S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) - - W_BETA=0.5D0 - DP45=W_BETA - DM45=W_BETA - -C END OF INITIALIZATION - - nca=ilastca-ishiftca - - call angvectors(nca) - call sheetforce(nca,wshet,dfaexp) - -c end of sheet energy and force - - do j=1,nca - shetfx(j)=shetfx(j)*beta_inc - shetfy(j)=shetfy(j)*beta_inc - shetfz(j)=shetfz(j)*beta_inc -c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) - enddo - - vbeta=vbeta*beta_inc - enebet=vbeta - edfabeta=enebet - - do j=1,nca - gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) - gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) - gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j) - enddo - - return - end -C------------------------------------------------------------------------------- - subroutine angvectors(nca) -c implicit real*4(a-h,o-z) - implicit none - integer nca - integer maxca - parameter(maxca=800) - real*8 pai,zero - parameter(PAI=3.14159265358979323846D0,zero=0.0d0) - - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 cph(maxca),cth(maxca) - real*8 ulcos(maxca) - real*8 p,c - integer i, ip, ipp, ip3, j - real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) - real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz - real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz - real*8 cix, ciy, ciz, cipx, cipy, cipz - real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g - real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 - real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 - real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 - real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri - real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim - real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm - real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm - real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm - real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr - real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz - real*8 grpp,gx,gy,gz - real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz - real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 - integer inb,nmax,iselect - - common /sheca/ bx,by,bz - common /difvec/ rx, ry, rz - common /ulang/ ulcos - common /phys1/ inb,nmax,iselect - common /phys4/ p,c - common /kyori2/ dis - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - & apmmz,apm3x,apm3y,apm3z - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - & atmmz,atm3x,atm3y,atm3z - common /coscos/ cph,cth - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C------------------------------------------------------------------------------- -c write(*,*) 'inside angvectors' -C initialize - p=0.1d0 - c=1.0d0 - inb=nca - cph=zero; cth=zero; sth=zero - apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero - apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero - atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero - atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero - astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero - astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero - astm3z=zero -C end of initialize -C r[x,y,z] calc and distance calculation - rx=zero;ry=zero;rz=zero - - do i=1,inb - do j=1,inb - rx(i,j)=bx(j)-bx(i) - ry(i,j)=by(j)-by(i) - rz(i,j)=bz(j)-bz(i) - dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) -c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -c write(*,*) 'dis(i,j):',i,j,dis(i,j) - enddo - enddo -c end of r[x,y,z] calc -C cos calc - do i=1,inb-2 - ip=i+1 - ipp=i+2 - - if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then - ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) - $ +rz(i,ip)*rz(ip,ipp) - ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) - endif - enddo -c end of virtual bond angle -c write(*,*) 'inside angvectors1' - do i=1,inb-3 - ip=i+1 - ipp=i+2 - ip3=i+3 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - rippx=bx(ip3)-bx(ipp) - rippy=by(ip3)-by(ipp) - rippz=bz(ip3)-bz(ipp) - - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - gpx=ripy*rippz-ripz*rippy - gpy=ripz*rippx-ripx*rippz - gpz=ripx*rippy-ripy*rippx - gpcrp_x=gpy*ripz-gpz*ripy - gpcrp_y=gpz*ripx-gpx*ripz - gpcrp_z=gpx*ripy-gpy*ripx - d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) - gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy - & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy - - if(i.ge.2) then - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - drim=dis(i-1,i) - drim3=drim**3 - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - endif -c write(*,*) 'inside angvectors2' - if(i.ge.3) then - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - drimm=dis(i-2,i-1) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - endif - - if(i.ge.4) then - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - endif - - dri=dis(i,i+1) - drip=dis(i+1,i+2) - dripp=dis(i+2,i+3) - dri3=dri**3 - dg=sqrt(gx**2+gy**2+gz**2) - dgp=sqrt(gpx**2+gpy**2+gpz**2) - dg3=dg**3 - - ggp=gx*gpx+gy*gpy+gz*gpz - grpp=gx*rippx+gy*rippy+gz*rippz - - if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 - & .and.d_gpcrp.gt.0.0D0) then - cph(i)=grpp/dg/dripp - cth(i)=ggp/dg/dgp - sth(i)=gpcrp__g/d_gpcrp/dg - else -c - cph(i)=1.0D0 - cth(i)=1.0D0 - sth(i)=0.0D0 - endif - -c write(*,*) 'inside angvectors3' - - if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 - & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then - d10=1.0D0/(dg*dgp) - d11=ggp/(dg3*dgp) - d12=1.0D0/(dg*dripp) - d13=grpp/(dg3*dripp) - sd10=1.0D0/(d_gpcrp*dg) - sd11=gpcrp__g/(d_gpcrp*dg3) - else - d10=0.0D0 - d11=0.0D0 - d12=0.0D0 - d13=0.0D0 - sd10=0.0D0 - sd11=0.0D0 - endif - - atx(i)=(ripz*gpy-ripy*gpz)*d10 - & -(gy*ripz-gz*ripy)*d11 - aty(i)=(ripx*gpz-ripz*gpx)*d10 - & -(gz*ripx-gx*ripz)*d11 - atz(i)=(ripy*gpx-ripx*gpy)*d10 - & -(gx*ripy-gy*ripx)*d11 - astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz - & +ripy*gpy*ripx-gpx*ripz**2) - & -sd11*(gy*ripz-gz*ripy) - asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx - & -gpy*ripx**2+gpz*ripy*ripz) - & -sd11*(-gx*ripz+gz*ripx) - astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 - & -gpz*ripy**2+ripz*gpx*ripx) - & -sd11*(gx*ripy-gy*ripx) - apx(i)=(ripz*rippy-ripy*rippz)*d12 - & -(gy*ripz-gz*ripy)*d13 - apy(i)=(ripx*rippz-ripz*rippx)*d12 - & -(gz*ripx-gx*ripz)*d13 - apz(i)=(ripy*rippx-ripx*rippy)*d12 - & -(gx*ripy-gy*ripx)*d13 - - if(i.ge.2) then - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 - & .and.d_gcr3.gt.0.0D0) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - endif - - if(i.ge.3) then - if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif - -c write(*,*) 'inside angvectors4' - -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -c********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - - if(i.ge.4) then - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -c********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - endif - enddo -c******************************************************************************* - -c write(*,*) 'inside angvectors5' - - do i=inb-2,inb - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - drim=dis(i-1,i) - drimm=dis(i-2,i-1) - drim3=drim**3 - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -cc********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - - if(i.le.inb-1) then - ip=i+1 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - dri=dis(i,i+1) - dri3=dri**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - - if(dgm3.gt.0.0D0.and. - & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -cc********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - -c write(*,*) 'inside angvectors6' - - if(i.eq.inb-2) then - ipp=i+2 - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - dg=sqrt(gx**2+gy**2+gz**2) - dg3=dg**3 - drip=dis(i+1,i+2) - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - if(dgm3.gt.0.0D0.and. - & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 - & ) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** -c - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - - endif - enddo - - return - end -c END of angvectors -c------------------------------------------------------------------------------- -C--------------------------------------------------------------------------------- - subroutine sheetforce(nca,wshet,dfaexp) - implicit none -C JYLEE -c this should be matched with dfa.fcm - integer maxca - parameter(maxca=800) -cc********************************************************************** - integer nca - integer i,k - integer inb,nmax,iselect - - real*8 dfaexp(15001) - - real*8 vbeta,vbetp,vbetm - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) - real*8 vbet(maxca,maxca) - real*8 wshet(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - - inb=nca - do i=1,inb - shetfx(i)=0.0D0 - shetfy(i)=0.0D0 - shetfz(i)=0.0D0 - enddo - - do k=1,12 - do i=1,inb - shefx(i,k)=0.0D0 - shefy(i,k)=0.0D0 - shefz(i,k)=0.0D0 - enddo - enddo - - call sheetene(nca,wshet,dfaexp) - call sheetforce1 - - 887 format(a,1x,i6,3x,f12.8) - 888 format(a,1x,i4,1x,i4,3x,f12.8) - 889 format(a,1x,i4,3x,f12.8) - !write(2,*) 'coord : ' - do i=1,inb - !write(2,887) 'bx:',i,bx(i) - !write(2,887) 'by:',i,by(i) - !write(2,887) 'bz:',i,bz(i) - enddo - !write(2,*) 'After sheetforce1' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce5 - - !write(2,*) 'After sheetforce5' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce6 - - !write(2,*) 'After sheetforce6' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce11 - - !write(2,*) 'After sheetforce11' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce12 - - !write(2,*) 'After sheetforce12' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - do i=1,inb - do k=1,12 - shetfx(i)=shetfx(i)+shefx(i,k) - shetfy(i)=shetfy(i)+shefy(i,k) - shetfz(i)=shetfz(i)+shefz(i,k) - enddo - enddo - !write(2,*) 'Beta Finished' - do i=1,inb - !write(2,889) 'shetfx : ',i,shetfx(i) - !write(2,889) 'shetfy : ',i,shetfy(i) - !write(2,889) 'shetfz : ',i,shetfz(i) - enddo - - return - end -C end sheetforce -c------------------------------------------------------------------------------- - subroutine sheetene(nca,wshet,dfaexp) - implicit none - integer maxca - parameter(maxca=800) -cc****************************************************************************** - - real*8 dfaexp(15001) - real*8 dtmp1, dtmp2, dtmp3 - - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 ulcos(maxca) -cc********************************************************************** - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 wshet(maxca,maxca) - real*8 dp45, dm45, w_beta - real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb - integer nca - integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect - real*8 uum, uup - real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -cc********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth - - real*8 r_pair_mat(maxca,maxca) - common /beta_p/ r_pair_mat -C------------------------------------------------------------------------------- - r_pair_mat = 0.0d0 - do i=1,inb - do j=1,inb - r_pair_mat(i,j)=wshet(i,j) -c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) - enddo - enddo -c stop -c - vbeta=0.0D0 - vbetp=0.0D0 - vbetm=0.0D0 - - do i=1,inb-7 - do j=i+4,inb-3 - ip=i+1 - ipp=i+2 - jp=j+1 - jpp=j+2 -cc********************************************************************** - y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 - & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 - y1=-0.5d0*y1/dca - y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 - & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 - y2=-0.5d0*y2/dnex - y=y1+y2 - - yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb - - pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) - $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) - pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) - $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) - pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) - $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) - pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) - $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) - - yshe1=pin1(i,j)**2+pin2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pin3(i,j)**2+pin4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -C write(*,*) 'dis(i,j):',i,j,dis(i,j) -C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) -C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) -C write(*,*) 'pin1:',pin1(i,j) -C write(*,*) 'pin2:',pin2(i,j) -C write(*,*) 'pin3:',pin3(i,j) -C write(*,*) 'pin4:',pin4(i,j) - -C write(*,*) 'y:',y -C write(*,*) 'yy1:',yy1 -C write(*,*) 'yy2:',yy2 -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -c - - dtmp1 = y+yy1+yshe1 - dtmp2 = y+yy2+yshe2 - dtmp3 = y+yy1+yy2+yshe1+yshe2 - -C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 -C write(*,*)'2', y,yy1,yy2 -C write(*,*)'3', yshe1,yshe2 - - if (dtmp3.le.-15.0d0) then -c vbetap(i,j)=-dp45*exp(dtmp3) - vbetap(i,j)=0.0d0 - else -c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) - vbetap(i,j)=-dp45*exp(dtmp3) - end if - - if (dtmp1.le.-15.0d0) then -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) - vbetap1(i,j)=0.0d0 - else -c vbetap1(i,j)=-r_pair_mat(i+1,j+1) -c $ *dfaexp(idint(-dtmp1*1000)+1) - vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) - end if - - if (dtmp2.le.-15.0d0) then -C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) - vbetap2(i,j)=0.0d0 - else -c vbetap2(i,j)=-r_pair_mat(i+2,j+2) -c $ *dfaexp(idint(-dtmp2*1000)+1) - vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) - end if - -c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) -c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) -! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) - - - yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb - - pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) - $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) - pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) - $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) - pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) - $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) - pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) - $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) - - yshe1=pina1(i,j)**2+pina2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pina3(i,j)**2+pina4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -C write(*,*) 'pina1:',pina1(i,j) -C write(*,*) 'pina2:',pina2(i,j) -C write(*,*) 'pina3:',pina3(i,j) -C write(*,*) 'pina4:',pina4(i,j) -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -C write(*,*) 'dshe:',dshe - - dtmp3=y+yy1+yy2+yshe1+yshe2 - dtmp1=y+yy1+yshe1 - dtmp2=y+yy2+yshe2 - - if(dtmp3 .le. -15.0d0) then -c vbetam(i,j)=-dm45*exp(dtmp3) - vbetam(i,j)=0.0d0 - else -c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) - vbetam(i,j)=-dm45*exp(dtmp3) - end if - - if(dtmp1 .le. -15.0d0) then -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) - vbetam1(i,j)=0.0d0 - else -c vbetam1(i,j)=-r_pair_mat(i+1,j+2) -c $ *dfaexp(idint(-dtmp1*1000)+1) - vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) - end if - - if(dtmp2.le.-15.0d0) then -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) - vbetam2(i,j)=0.0d0 - else -c vbetam2(i,j)=-r_pair_mat(i+2,j+1) -c $ *dfaexp(idint(-dtmp2*1000)+1) - vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) - end if - -c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) -! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) - - uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) - uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) - -c write(*,*) 'uup,uum:', uup, uum - -c uup=vbetap1(i,j)+vbetap2(i,j) -c uum=vbetam1(i,j)+vbetam2(i,j) - - vbet(i,j)=uup+uum - vbetp=vbetp+uup - vbetm=vbetm+uum - vbeta=vbeta+vbet(i,j) - -c write(*,*) 'uup,uum:',uup,uum -c write(*,*) 'vbetap(i,j):',vbetap(i,j) -c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -c write(*,*) 'vbetam(i,j):',vbetam(i,j) -c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -c write(*,*) 'uup:',uup -c write(*,*) 'uum:',uum -c write(*,*) 'vbetp:',vbetp -c write(*,*) 'vbetm:',vbetm -c write(*,*) 'vbet(i,j):',vbet(i,j) -c stop - - enddo - enddo - -! do i=1,inb-7 -! do j=i+4,inb-3 -! write(*,*) 'I,J:', i,j -! write(*,*) 'vbetap(i,j):',vbetap(i,j) -! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -! write(*,*) 'vbetam(i,j):',vbetam(i,j) -! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -! write(*,*) 'vbet(i,j):',vbet(i,j) -! enddo -! enddo - - return - end -c------------------------------------------------------------------------------- - subroutine sheetforce1 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 ulcos(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 w_beta,dp45, dm45 - real*8 vbeta, vbetp, vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect - - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - $ atmmz,atm3x,atm3y,atm3z - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - $ apmmz,apm3x,apm3y,apm3z - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -c c********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - $ astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C-------------------------------------------------------------------------------- -c local variables - integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp - real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 - real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 - real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 - real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 -C-------------------------------------------------------------------------------- - do i=4,inb-4 - im3=i-3 - imm=i-2 - im=i-1 - c1=(cth(im3)*c00+sth(im3)*s00-1)/dca - v1=0.0D0 - do j=i+1,inb-3 - v1=v1+vbet(im3,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - dmm=cc1/(dis(imm,im)*dis(im,i)) - dmm__=cc1*ulcos(imm)/dis(im,i)**2 - fx=rx(imm,im)*dmm-rx(im,i)*dmm__ - fy=ry(imm,im)*dmm-ry(im,i)*dmm__ - fz=rz(imm,im)*dmm-rz(im,i)*dmm__ - fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 - fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 - fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 - shefx(i,1)=fx*v1 - shefy(i,1)=fy*v1 - shefz(i,1)=fz*v1 - enddo - - do i=3,inb-5 - imm=i-2 - im=i-1 - ip=i+1 - c2=(cth(imm)*c00+sth(imm)*s00-1)/dca - v2=0.0D0 - do j=i+2,inb-3 - v2=v2+vbet(imm,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - cc2=(ulcos(im)-ulnex)/dnex - dmm1=cc1/(dis(imm,im)*dis(im,i)) - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm1__=cc1*ulcos(imm)/dis(im,i)**2 - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 -cc********************************************************************** - fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 - fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 - fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 - fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 - fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 - fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 - shefx(i,2)=fx*v2 - shefy(i,2)=fy*v2 - shefz(i,2)=fz*v2 - enddo - do i=2,inb-6 - im=i-1 - ip=i+1 - ipp=i+2 - c3=(cth(im)*c00+sth(im)*s00-1)/dca - v3=0.0D0 - do j=i+3,inb-3 - v3=v3+vbet(im,j) - enddo - cc2=(ulcos(im)-ulnex)/dnex - cc3=(ulcos(i)-ulnex)/dnex - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ - fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 - fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 - fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 - shefx(i,3)=fx*v3 - shefy(i,3)=fy*v3 - shefz(i,3)=fz*v3 - enddo - do i=1,inb-7 - ip=i+1 - ipp=i+2 - c4=(cth(i)*c00+sth(i)*s00-1)/dca - v4=0.0D0 - do j=i+4,inb-3 - v4=v4+vbet(i,j) - enddo - cc3=(ulcos(i)-ulnex)/dnex - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ - fx=fx+(atx(i)*c00+astx(i)*s00)*c4 - fy=fy+(aty(i)*c00+asty(i)*s00)*c4 - fz=fz+(atz(i)*c00+astz(i)*s00)*c4 - shefx(i,4)=fx*v4 - shefy(i,4)=fy*v4 - shefz(i,4)=fz*v4 - enddo - do j=8,inb - jm3=j-3 - jmm=j-2 - jm=j-1 - c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca - v7=0.0D0 - do i=1,j-7 - v7=v7+vbet(i,jm3) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - dmm=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 - fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ - fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ - fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ - fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 - fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 - fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 - shefx(j,7)=fx*v7 - shefy(j,7)=fy*v7 - shefz(j,7)=fz*v7 - enddo - do j=7,inb-1 - jm=j-1 - jmm=j-2 - jp=j+1 - c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca - v8=0.0D0 - do i=1,j-6 - v8=v8+vbet(i,jmm) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - cc8=(ulcos(jm)-ulnex)/dnex - dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 - fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 - fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 - fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 - fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 - fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 - shefx(j,8)=fx*v8 - shefy(j,8)=fy*v8 - shefz(j,8)=fz*v8 - enddo - - do j=6,inb-2 - jm=j-1 - jp=j+1 - jpp=j+2 - c9=(cth(jm)*c00+sth(jm)*s00-1)/dca - v9=0.0D0 - do i=1,j-5 - v9=v9+vbet(i,jm) - enddo - cc8=(ulcos(jm)-ulnex)/dnex - cc9=(ulcos(j)-ulnex)/dnex - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ - fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 - fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 - fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 - shefx(j,9)=fx*v9 - shefy(j,9)=fy*v9 - shefz(j,9)=fz*v9 - enddo - - do j=5,inb-3 - jp=j+1 - jpp=j+2 - c10=(cth(j)*c00+sth(j)*s00-1)/dca - v10=0.0D0 - do i=1,j-4 - v10=v10+vbet(i,j) - enddo - cc9=(ulcos(j)-ulnex)/dnex - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ - fx=fx+(atx(j)*c00+astx(j)*s00)*c10 - fy=fy+(aty(j)*c00+asty(j)*s00)*c10 - fz=fz+(atz(j)*c00+astz(j)*s00)*c10 - shefx(j,10)=fx*v10 - shefy(j,10)=fy*v10 - shefz(j,10)=fz*v10 - enddo - - return - end -c---------------------------------------------------------------------------- - subroutine sheetforce5 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -c******************************************************************************** -c local variables - integer i,imm,im,jp,jpp,j - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z - real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b -c******************************************************************************** - do i=3,inb-5 - imm=i-2 - im=i-1 - do j=i+2,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jpp)-ulhb)/dlhb - y1x=rx(jpp,i)/dis(i,jpp) - y1y=ry(jpp,i)/dis(i,jpp) - y1z=rz(jpp,i)/dis(i,jpp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(im,jp)*dis(im,i)) - yyy3=pin1(imm,j)/(dis(im,i)**2) - yy3=-pin1(imm,j)/dshe - y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 - y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 - y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 - - yy44=1.0D0/(dis(i,jpp)*dis(im,i)) - yyy4a=pin3(imm,j)/(dis(i,jpp)**2) - yyy4b=pin3(imm,j)/(dis(im,i)**2) - yy4=-pin3(imm,j)/dshe - y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) - $ -yyy4b*rx(im,i))*yy4 - y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) - $ -yyy4b*ry(im,i))*yy4 - y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) - $ -yyy4b*rz(im,i))*yy4 - - - yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy5=pin4(imm,j)/(dis(i,jpp)**2) - yy5=-pin4(imm,j)/dshe - y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 - y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 - y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) - $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) - $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) - $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - - yy6=-(dis(i,jp)-uldhb)/dldhb - y6x=rx(jp,i)/dis(i,jp) - y6y=ry(jp,i)/dis(i,jp) - y6z=rz(jp,i)/dis(i,jp) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(im,jpp)*dis(im,i)) - yyy8=pina1(imm,j)/(dis(im,i)**2) - yy8=-pina1(imm,j)/dshe - y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 - y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 - y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 - - yy99=1.0D0/(dis(jp,i)*dis(im,i)) - yyy9a=pina3(imm,j)/(dis(jp,i)**2) - yyy9b=pina3(imm,j)/(dis(im,i)**2) - yy9=-pina3(imm,j)/dshe - y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) - $ -yyy9b*rx(im,i))*yy9 - y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) - $ -yyy9b*ry(im,i))*yy9 - y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) - $ -yyy9b*rz(im,i))*yy9 - - yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) - yyy10=pina4(imm,j)/(dis(jp,i)**2) - yy10=-pina4(imm,j)/dshe - y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 - y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 - y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) - $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) - $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) - $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - - enddo - enddo - - return - end -c--------------------------------------------------------------------------c - subroutine sheetforce6 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer i,imm,im,jp,jpp,j,ip - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 - real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b -C******************************************************************************** - do i=2,inb-6 - ip=i+1 - im=i-1 - do j=i+3,inb-3 - jp=j+1 - jpp=j+2 - - yy1=-(dis(i,jp)-ulhb)/dlhb - y1x=rx(jp,i)/dis(i,jp) - y1y=ry(jp,i)/dis(i,jp) - y1z=rz(jp,i)/dis(i,jp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(i,jp)*dis(i,ip)) - yyy3a=pin1(im,j)/(dis(i,jp)**2) - yyy3b=pin1(im,j)/(dis(i,ip)**2) - yy3=-pin1(im,j)/dshe - y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) - $ +yyy3b*rx(i,ip))*yy3 - y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) - $ +yyy3b*ry(i,ip))*yy3 - y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) - $ +yyy3b*rz(i,ip))*yy3 - - yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) - yyy4=pin2(im,j)/(dis(i,jp)**2) - yy4=-pin2(im,j)/dshe - y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 - y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 - y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 - - yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) - yyy5=pin3(im,j)/(dis(i,ip)**2) - yy5=-pin3(im,j)/dshe - y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 - y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 - y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) - $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) - $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) - $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) - - yy6=-(dis(jpp,i)-uldhb)/dldhb - y6x=rx(jpp,i)/dis(jpp,i) - y6y=ry(jpp,i)/dis(jpp,i) - y6z=rz(jpp,i)/dis(jpp,i) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) - yyy8a=pina1(im,j)/(dis(i,jpp)**2) - yyy8b=pina1(im,j)/(dis(i,ip)**2) - yy8=-pina1(im,j)/dshe - y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) - $ +yyy8b*rx(i,ip))*yy8 - y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) - $ +yyy8b*ry(i,ip))*yy8 - y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) - $ +yyy8b*rz(i,ip))*yy8 - - yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy9=pina2(im,j)/(dis(i,jpp)**2) - yy9=-pina2(im,j)/dshe - y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 - y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 - y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 - - yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) - yyy10=pina3(im,j)/(dis(i,ip)**2) - yy10=-pina3(im,j)/dshe - y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 - y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 - y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) - $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) - $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) - $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce11 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -C******************************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 - real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 -C******************************************************************************** - - do j=7,inb-1 - jm=j-1 - jmm=j-2 - do i=1,j-6 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ipp,j)-ulhb)/dlhb - y1x=rx(ipp,j)/dis(ipp,j) - y1y=ry(ipp,j)/dis(ipp,j) - y1z=rz(ipp,j)/dis(ipp,j) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) - yyy3=pin2(i,jmm)/(dis(jm,j)**2) - yy3=-pin2(i,jmm)/dshe - y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 - y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 - y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 - - yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) - yyy4=pin3(i,jmm)/(dis(ipp,j)**2) - yy4=-pin3(i,jmm)/dshe - y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 - y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 - y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 - - yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) - yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) - yyy5b=pin4(i,jmm)/(dis(jm,j)**2) - yy5=-pin4(i,jmm)/dshe - y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) - $ -yyy5b*rx(jm,j))*yy5 - y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) - $ -yyy5b*ry(jm,j))*yy5 - y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) - $ -yyy5b*rz(jm,j))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) - $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) - $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) - $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - - yy6=-(dis(ip,j)-uldhb)/dldhb - y6x=rx(ip,j)/dis(ip,j) - y6y=ry(ip,j)/dis(ip,j) - y6z=rz(ip,j)/dis(ip,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy8=pina1(i,jmm)/(dis(ip,j)**2) - yy8=-pina1(i,jmm)/dshe - y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 - y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 - y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 - - yy99=1.0D0/(dis(ip,j)*dis(jm,j)) - yyy9a=pina2(i,jmm)/(dis(ip,j)**2) - yyy9b=pina2(i,jmm)/(dis(jm,j)**2) - yy9=-pina2(i,jmm)/dshe - y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) - $ -yyy9b*rx(jm,j))*yy9 - y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) - $ -yyy9b*ry(jm,j))*yy9 - y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) - $ -yyy9b*rz(jm,j))*yy9 - - yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) - yyy10=pina4(i,jmm)/(dis(jm,j)**2) - yy10=-pina4(i,jmm)/dshe - y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 - y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 - y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) - $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) - $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) - $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce12 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -cc********************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp,jp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 -!c*************************************************************************c - do j=6,inb-2 - jp=j+1 - jm=j-1 - do i=1,j-5 - ip=i+1 - ipp=i+2 - - yy1=-(dis(ip,j)-ulhb)/dlhb - y1x=rx(ip,j)/dis(ip,j) - y1y=ry(ip,j)/dis(ip,j) - y1z=rz(ip,j)/dis(ip,j) - y11x=y1x*yy1 - y11y=y1y*yy1 - y11z=y1z*yy1 - - yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy3=pin1(i,jm)/(dis(ip,j)**2) - yy3=-pin1(i,jm)/dshe - y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 - y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 - y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 - yy44=1.0D0/(dis(ip,j)*dis(j,jp)) - - yyy4a=pin2(i,jm)/(dis(ip,j)**2) - yyy4b=pin2(i,jm)/(dis(j,jp)**2) - yy4=-pin2(i,jm)/dshe - y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) - $ +yyy4b*rx(j,jp))*yy4 - y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) - $ +yyy4b*ry(j,jp))*yy4 - y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) - $ +yyy4b*rz(j,jp))*yy4 - - yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) - yyy5=pin4(i,jm)/(dis(j,jp)**2) - yy5=-pin4(i,jm)/dshe - y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 - y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 - y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) - $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) - $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) - $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - -! shefx(j,12)=shefx(j,12) -! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) -! shefy(j,12)=shefy(j,12) -! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) -! shefz(j,12)=shefz(j,12) -! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - - yy6=-(dis(ipp,j)-uldhb)/dldhb - y6x=rx(ipp,j)/dis(ipp,j) - y6y=ry(ipp,j)/dis(ipp,j) - y6z=rz(ipp,j)/dis(ipp,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) - yyy8=pina2(i,jm)/(dis(j,jp)**2) - yy8=-pina2(i,jm)/dshe - y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 - y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 - y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 - - yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) - yyy9=pina3(i,jm)/(dis(j,ipp)**2) - yy9=-pina3(i,jm)/dshe - y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 - y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 - y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 - - yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) - yyy10a=pina4(i,jm)/(dis(j,ipp)**2) - yyy10b=pina4(i,jm)/(dis(j,jp)**2) - yy10=-pina4(i,jm)/dshe - y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) - $ +yyy10b*rx(j,jp))*yy10 - y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) - $ +yyy10b*ry(j,jp))*yy10 - y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) - $ +yyy10b*rz(j,jp))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) - $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) - $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) - $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) - - ENDDO - ENDDO - - RETURN - END -C=============================================================================== diff --git a/source/unres/src_CSA/diff12.f b/source/unres/src_CSA/diff12.f index 3d347ed..13de22e 100644 --- a/source/unres/src_CSA/diff12.f +++ b/source/unres/src_CSA/diff12.f @@ -6,9 +6,64 @@ cccccccccccccccccccccccccccccccccc include 'COMMON.BANK' include 'COMMON.CHAIN' include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.VAR' dimension aarray(mxang,maxres,mxch), & barray(mxang,maxres,mxch) + real x1(maxres),y1(maxres),z1(maxres) + integer n_1(maxres),L1 + real x2(maxres),y2(maxres),z2(maxres) + integer n_2(maxres),L2 + real TM,Rcomm + integer Lcomm + + IF(tm_score) THEN + + do k=1,numch + do j=2,nres-1 + theta(j+1)=barray(1,j,k) + phi(j+2)=barray(2,j,k) + alph(j)=barray(3,j,k) + omeg(j)=barray(4,j,k) + enddo + enddo + call chainbuild + L1=0 + do i=nnt,nct + L1=L1+1 + n_1(L1)=L1 + x1(L1)=c(1,i) + y1(L1)=c(2,i) + z1(L1)=c(3,i) + enddo + + do k=1,numch + do j=2,nres-1 + theta(j+1)=aarray(1,j,k) + phi(j+2)=aarray(2,j,k) + alph(j)=aarray(3,j,k) + omeg(j)=aarray(4,j,k) + enddo + enddo + call chainbuild + L2=0 + do i=nnt,nct + L2=L2+1 + n_2(L2)=L2 + x2(L2)=c(1,i) + y2(L2)=c(2,i) + z2(L2)=c(3,i) + enddo + + call TMscore(L1,x1,y1,z1,n_1,L2,x2,y2,z2,n_2,TM,Rcomm,Lcomm) + diff=1.0d0-TM + +cd write(*,*)'TMscore=',TM,diff +cd write(*,*)'Number of residues in common=',Lcomm +cd write(*,*)'RMSD of the common residues=',Rcomm + + ELSE diff=0.d0 do k=1,numch do j=2,nres-1 @@ -21,7 +76,7 @@ c do i=1,2 enddo enddo enddo - + ENDIF return end ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_CSA/initialize_p.F b/source/unres/src_CSA/initialize_p.F index fb74940..19cf3d6 100644 --- a/source/unres/src_CSA/initialize_p.F +++ b/source/unres/src_CSA/initialize_p.F @@ -271,9 +271,9 @@ c------------------------------------------------------------------------- & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR", & " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/ - data nprint_ene /20/ + data nprint_ene /24/ data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16, - & 21,0,0,0,0,0,0,0/ + & 21,24,25,26,27,0,0,0/ end c--------------------------------------------------------------------------- subroutine init_int_table diff --git a/source/unres/src_CSA/minim_jlee.F b/source/unres/src_CSA/minim_jlee.F index d83b15b..f1e00be 100644 --- a/source/unres/src_CSA/minim_jlee.F +++ b/source/unres/src_CSA/minim_jlee.F @@ -42,6 +42,12 @@ c print *, 'MINIM_JLEE: ',me,' is waiting' time1s=MPI_WTIME() write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' call flush(iout) + if (info(1).eq.0.and.info(2).eq.-2) then +cd write (iout,*) 'Parallel tmscore for refresh bank' +cd call flush(iout) + call refresh_bank_worker_tmscore(var) + goto 10 + endif n=info(1) c print *, 'MINIM_JLEE: ',me,' received: ',n diff --git a/source/unres/src_CSA/readrtns_csa.F b/source/unres/src_CSA/readrtns_csa.F index c67d045..a00df40 100644 --- a/source/unres/src_CSA/readrtns_csa.F +++ b/source/unres/src_CSA/readrtns_csa.F @@ -1131,6 +1131,9 @@ c!bankt call readi(mcmcard,'NCONF_IN',nconf_in,0) call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) write (iout,*) "NCONF_IN",nconf_in + tm_score=(index(mcmcard,'TMSCORE').gt.0) + if (tm_score) write (iout,*) "Using TM_Score instead of DIFF", + & " for torsional angles" return end diff --git a/source/unres/src_CSA/rmsd.F b/source/unres/src_CSA/rmsd.F index 52e7b37..8e07b0c 100644 --- a/source/unres/src_CSA/rmsd.F +++ b/source/unres/src_CSA/rmsd.F @@ -138,3 +138,47 @@ c-------------------------------------------- return end +c--------------------------------------------------------------------------- + subroutine calc_tmscore(tmscore_dp,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.INTERACT' + real x1(maxres),y1(maxres),z1(maxres) + integer n_1(maxres),L1 + real x2(maxres),y2(maxres),z2(maxres) + integer n_2(maxres),L2 + real TM,Rcomm + integer Lcomm + logical lprn + + L1=0 +c print *,"nz_start",nz_start," nz_end",nz_end + do i=nz_start,nz_end + L1=L1+1 + n_1(L1)=L1 + x1(L1)=c(1,i+nstart_seq-nstart_sup) + y1(L1)=c(2,i+nstart_seq-nstart_sup) + z1(L1)=c(3,i+nstart_seq-nstart_sup) + + n_2(L1)=L1 + x2(L1)=cref(1,i) + y2(L1)=cref(2,i) + z2(L1)=cref(3,i) + enddo + L2=L1 + + call TMscore(L1,x1,y1,z1,n_1,L2,x2,y2,z2,n_2,TM,Rcomm,Lcomm) + + tmscore_dp=TM + if (lprn) then + write (iout,'(a40,f8.2)') + & 'TM-score with the reference structure: ',TM + endif + return + end + diff --git a/source/unres/src_CSA/together.F b/source/unres/src_CSA/together.F index 558dbad..5737b48 100644 --- a/source/unres/src_CSA/together.F +++ b/source/unres/src_CSA/together.F @@ -210,6 +210,8 @@ c Output to $mol.reminimized if (irestart.eq.1) goto 111 c soldier - perform energy minimization 334 call minim_jlee + + ENDIF ccccccccccccccccccccccccccccccccccc @@ -309,12 +311,17 @@ c call find_max call find_min - - call get_diff + + if (tm_score) then + call get_diff_p + else + call get_diff + endif if(nbank.eq.nconf.and.irestart.eq.0) then adif=avedif endif + write (iout,*) "AVEDIF",avedif cutdif=adif/cut1 ctdif1=adif/cut2 @@ -401,6 +408,27 @@ ct print *,'waiting ',MPI_WTIME() irecv=irecv+1 call recv(0,ifrom,xout,eout,ind,timeout) ct print *,' ',irecv,' received from',ifrom,MPI_WTIME() + + if(tm_score) then + nft=nft+ind(3) + movernx(irecv)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) + if(vdisulf) then + nss_out(irecv)=nss + do i=1,nss + iss_out(i,irecv)=ihpb(i) + jss_out(i,irecv)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) + endif + + if(tm_score.and.eout(1).lt.ebmax) then + if(iref.eq.0 .or. + & (rmsn(irecv).le.rmscut.and.pncn(irecv).ge.pnccut)) + & call refresh_bank_master_tmscore(ifrom,eout(1),irecv) + endif else ifrom=ifrom+1 endif @@ -410,7 +438,7 @@ ct print *,'sending to',ifrom,MPI_WTIME() ct print *,isent,' sent ',MPI_WTIME() c store results ----------------------------------------------- - if (isent.ge.nodes.or.iter.gt.0) then + if ((isent.ge.nodes.or.iter.gt.0).and..not.tm_score) then nft=nft+ind(3) movernx(irecv)=iabs(ind(5)) call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) @@ -443,7 +471,18 @@ c-------------------------------------------------------------- iter=iter+1 c----------------- call update(ntry-nodes+1) ------------------- nstep=nstep+ntry-nseed-(nodes-1) - call refresh_bank(ntry-nodes+1) + if (tm_score) then +ctm call refresh_bank(ntry) + call print_mv_stat + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + else + call refresh_bank(ntry-nodes+1) + endif c!bankt call refresh_bankt(ntry-nodes+1) else c----------------- call update(ntry) --------------------------- @@ -451,7 +490,18 @@ c----------------- call update(ntry) --------------------------- print *,'UPDATING ',ntry,irecv write(iout,*) 'UPDATING ',ntry nstep=nstep+ntry-nseed - call refresh_bank(ntry) + if (tm_score) then +ctm call refresh_bank(ntry) + call print_mv_stat + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + else + call refresh_bank(ntry) + endif c!bankt call refresh_bankt(ntry) endif c----------------------------------------------------------------- @@ -611,6 +661,9 @@ c!bankt call write_bankt(jlee,nft) irecv=0 endif ELSE + if (tm_score) then + call get_diff_p + endif c soldier - perform energy minimization call minim_jlee print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start @@ -1206,6 +1259,7 @@ c halt soldier c print *,'sending halt to ',man write(iout,*) 'sending halt to ',man info(1)=0 + info(2)=0 call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) endif return diff --git a/source/unres/src_CSA/unres_csa.F b/source/unres/src_CSA/unres_csa.F index ac19d24..51d6bca 100644 --- a/source/unres/src_CSA/unres_csa.F +++ b/source/unres/src_CSA/unres_csa.F @@ -90,8 +90,8 @@ c else if (modecalc.eq.2) then c call exec_thread c else if (modecalc.eq.3 .or. modecalc .eq.6) then c call exec_MC -c else if (modecalc.eq.4) then -c call exec_mult_eeval_or_minim + else if (modecalc.eq.4) then + call exec_mult_eeval_or_minim else if (modecalc.eq.5) then call exec_checkgrad c else if (ModeCalc.eq.7) then @@ -301,3 +301,244 @@ C This method works only with parallel machines! #endif return end +c--------------------------------------------------------------------------- + subroutine exec_mult_eeval_or_minim + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + integer muster(mpi_status_size) + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision varia(maxvar) + integer ind(6) + double precision energy(0:n_ene) + logical eof + eof=.false. + + if(me.ne.king) then + call minim_mcmf + return + endif + + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,100a12)')"# ", + & (wname(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,100a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene), + & "ETOT total","RMSD","nat.contact","nnt.contact", + & "cont.order","TMscore" + else + write (istat,'(a5,100a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" + endif + + if (.not.minim) then + do while (.not. eof) + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene + call read_x(intin,*11) +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1100,err=1100) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + call etotal(energy(0)) + call briefout(iconf,energy(0)) + call enerprint(energy(0)) + etot=energy(0) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + enddo +1100 continue + goto 1101 + endif + + mm=0 + imm=0 + nft=0 + ene0=0.0d0 + n=0 + iconf=0 + do while (.not. eof) + mm=mm+1 + if (mm.lt.nodes) then + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene + call read_x(intin,*11) +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=11,err=11) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + + n=n+1 + write (iout,*) 'Conformation #',iconf,' read' + imm=imm+1 + ind(1)=1 + ind(2)=n + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + ene0=0.0d0 + call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM, + * ierr) + call mpi_send(varia,nvar,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) +c print *,'task ',n,' sent to worker ',mm,nvar + else + call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, + * CG_COMM,muster,ierr) + man=muster(mpi_source) +c print *,'receiving result from worker ',man,' (',iii1,iii,')' + call mpi_recv(varia,nvar,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene,1, + * mpi_double_precision,man,idreal, + * CG_COMM,muster,ierr) + call mpi_recv(ene0,1, + * mpi_double_precision,man,idreal, + * CG_COMM,muster,ierr) +c print *,'result received from worker ',man,' sending now' + + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energy(0)) + iconf=ind(2) + write (iout,*) + write (iout,*) + write (iout,*) 'Conformation #',iconf,ind(5) + + etot=energy(0) + call enerprint(energy(0)) + call briefout(iconf,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + + imm=imm-1 + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene + call read_x(intin,*11) +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1101,err=1101) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + n=n+1 + write (iout,*) 'Conformation #',iconf,' read' + imm=imm+1 + ind(1)=1 + ind(2)=n + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM, + * ierr) + call mpi_send(varia,nvar,mpi_double_precision,man, + * idreal,CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,man, + * idreal,CG_COMM,ierr) + nf_mcmf=nf_mcmf+ind(4) + nmin=nmin+1 + endif + enddo +11 continue + do j=1,imm + call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, + * CG_COMM,muster,ierr) + man=muster(mpi_source) + call mpi_recv(varia,nvar,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene,1, + * mpi_double_precision,man,idreal, + * CG_COMM,muster,ierr) + call mpi_recv(ene0,1, + * mpi_double_precision,man,idreal, + * CG_COMM,muster,ierr) + + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energy(0)) + iconf=ind(2) + write (iout,*) + write (iout,*) + write (iout,*) 'Conformation #',iconf,ind(5) + + etot=energy(0) + call enerprint(energy(0)) + call briefout(iconf,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + nmin=nmin+1 + enddo +1101 continue + do i=1, nodes-1 + ind(1)=0 + ind(2)=0 + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM, + * ierr) + enddo + return + end +c--------------------------------------------------------------------------- + -- 1.7.9.5