diff --git a/BasicWLC/BDcode/BDsim.f90 b/BasicWLC/BDcode/BDsim.f90 new file mode 100644 index 00000000..cab31048 --- /dev/null +++ b/BasicWLC/BDcode/BDsim.f90 @@ -0,0 +1,315 @@ +!---------------------------------------------------------------* + + SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & + INTON,IDUM,PARA,SIMTYPE,HAS_COLLIDED,FPT_DIST, & + COL_TYPE, METH_STATUS, KM, KD, NUM_SPREAD, IN_RXN_RAD, PAIRS, NUC_SITE, NUM_METHYLATED, NUM_DECAY) + +! +! External subroutine to perform a Brownian dynamics simulation. +! +! Andrew Spakowitz +! Written 11-11-13 + + use mt19937, only : rnorm + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION TIME ! Time of BD simulation + DOUBLE PRECISION TTOT ! Final time of BD simulation + INTEGER N,NP,NT ! Number of beads + +! Variables in the simulation + + DOUBLE PRECISION B(NT,1) ! Bond length + DOUBLE PRECISION RS(NT,3) ! R during the step + DOUBLE PRECISION US(NT,3) ! R during the step + DOUBLE PRECISION L0 ! Bond distances + DOUBLE PRECISION DT,DT0 ! Time step size + INTEGER RK ! Runge-Kutta index + DOUBLE PRECISION DRDT(NT,3,4) ! Position rate of change + DOUBLE PRECISION DUDT(NT,3,4) ! Position rate of change + INTEGER I,J,IB ! Index Holders + DOUBLE PRECISION DOTU + DOUBLE PRECISION R0(3) + +! Variables for use in the force calculations + + DOUBLE PRECISION FELAS(NT,3) ! Elastic force + DOUBLE PRECISION FPONP(NT,3) ! self-int force + DOUBLE PRECISION TELAS(NT,3) ! Elastic force + DOUBLE PRECISION TPONP(NT,3) ! self-int force + DOUBLE PRECISION FORCE ! External force + INTEGER FON ! Is force on? + +! Variables in the simulation + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION PARA(10) + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Variables used for the Brownian forces + + DOUBLE PRECISION FRAND(NT,3) ! Random force + DOUBLE PRECISION TRAND(NT,3) ! Random force + DOUBLE PRECISION MAGR,MAGU ! Mag of Brownian forces + INTEGER BROWN ! Logic for BD forces + INTEGER INTON ! Include polymer interactions + REAL ran1 ! Random number generator + INTEGER IDUM ! Seed for the generator + INTEGER NOW(3) ! Time now (hr,min,sec) + +! Variables for the timestep switch + + INTEGER SWDT + +! Variable to hold time of first collisions between each bead + DOUBLE PRECISION HAS_COLLIDED(NT,NT) + DOUBLE PRECISION FPT_DIST ! l1 dist to trigger collision + INTEGER COL_TYPE ! algorithm to use for collision detection + +! Variables for tracking methylation profile + INTEGER IN_RXN_RAD(NT,NT) ! is pair of sites within reaction radius? 1 = yes, 0 = no + INTEGER METH_STATUS(NT) ! methylation status of each site: 1 = methylated, 0 = unmethylated + INTEGER COULD_REACT ! number of pairs that meet criteria for reaction (i.e. within reaction radius, one bead methylated, one bead unmethylated) + INTEGER PAIRS(2,NT) ! array that holds indices of sites that could react + INTEGER RXN_HAPPEN ! reaction status: 1 = reaction, 0 = no reaction + DOUBLE PRECISION KM ! rate of methylation + DOUBLE PRECISION KD ! rate of demethylation + DOUBLE PRECISION KTOT ! total rate constant + INTEGER NUM_METHYLATED ! number of methylated sites + INTEGER NUM_SPREAD ! total number of spreading events + INTEGER NUC_SITE ! index of nucleation site + INTEGER NUM_DECAY ! total number of decay events + DOUBLE PRECISION DT_MOD ! time remaining in timestep for Gillespie algorithm + +! Load the input parameters + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + XIR=PARA(6) + XIU=PARA(7) + LBOX=PARA(8) + LHC=PARA(9) + VHC=PARA(10) + + MAGR=sqrt(XIR*2.0/DT) + MAGU=sqrt(XIU*2.0/DT) + DT0=DT + SWDT=0 + +! Setup the geometric parameters and initialize random forces + + IB=1 + DO 10 I=1,NP + DO 20 J=1,N + RS(IB,1)=R(IB,1) + RS(IB,2)=R(IB,2) + RS(IB,3)=R(IB,3) + US(IB,1)=U(IB,1) + US(IB,2)=U(IB,2) + US(IB,3)=U(IB,3) + FELAS(IB,1)=0. + FELAS(IB,2)=0. + FELAS(IB,3)=0. + FRAND(IB,1)=0. + FRAND(IB,2)=0. + FRAND(IB,3)=0. + FPONP(IB,1)=0. + FPONP(IB,2)=0. + FPONP(IB,3)=0. + TELAS(IB,1)=0. + TELAS(IB,2)=0. + TELAS(IB,3)=0. + TRAND(IB,1)=0. + TRAND(IB,2)=0. + TRAND(IB,3)=0. + TPONP(IB,1)=0. + TPONP(IB,2)=0. + TPONP(IB,3)=0. + IB=IB+1 + 20 CONTINUE + 10 CONTINUE + + RXN_HAPPEN = 1 + +! Begin the time integration + + DO WHILE (TIME.LT.TTOT) + + call CHECK_COLLISIONS(R, NT, HAS_COLLIDED, FPT_DIST, TIME, COL_TYPE, IN_RXN_RAD) + + DT_MOD = DT + + DO WHILE (RXN_HAPPEN.EQ.1) + + COULD_REACT = 0 + + call CHECK_REACTIONS(R, NT, METH_STATUS, IN_RXN_RAD, COULD_REACT, FPT_DIST, PAIRS) + + call TOT_RATE_CONSTANT(NT, COULD_REACT, METH_STATUS, KM, KD, KTOT, NUM_METHYLATED) + + call METHYL_PROFILE(NT,METH_STATUS,KTOT,KM,KD,NUM_METHYLATED,TIME, & + RXN_HAPPEN,PAIRS,DT,DT_MOD,NUC_SITE,NUM_SPREAD,NUM_DECAY) + + END DO + + RXN_HAPPEN = 1 + +! Calculate the random forces and torques for use in this +! timestep calculation if BROWN=1 + + RK=1 + DO WHILE (RK.LE.4) + + 130 CONTINUE + + if (BROWN.EQ.1.AND.RK.EQ.1) then + IB=1 + DO 30 I=1,NP + DO 40 J=1,N + FRAND(IB,1)=MAGR*rnorm() + FRAND(IB,2)=MAGR*rnorm() + FRAND(IB,3)=MAGR*rnorm() + TRAND(IB,1)=MAGU*rnorm() + TRAND(IB,2)=MAGU*rnorm() + TRAND(IB,3)=MAGU*rnorm() + IB=IB+1 + 40 CONTINUE + 30 CONTINUE + endif + +! Calculate the four Runge-Kutta derivatives + + +! Calculate the elastic forces (same as free chain) + + call force_elas(FELAS,TELAS,R,U,NT,N,NP,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + +! Calculate the self forces + + if (INTON.EQ.1) then + call force_ponp(FPONP,R,NT,N,NP,LHC,VHC,LBOX,GAM,DT,XIR,SWDT) + +! If timestep is switch, reset coords and redo step + + if (SWDT.EQ.1) then + print*, "Time-step switch", DT,RK,TIME + SWDT=0 + MAGR=sqrt(XIR*2.0/DT) + MAGU=sqrt(XIU*2.0/DT) + IB=1 + DO 60 I=1,NP + DO 65 J=1,N + R(IB,1)=RS(IB,1) + R(IB,2)=RS(IB,2) + R(IB,3)=RS(IB,3) + U(IB,1)=US(IB,1) + U(IB,2)=US(IB,2) + U(IB,3)=US(IB,3) + IB=IB+1 + 65 CONTINUE + 60 CONTINUE + RK=1 + goto 130 + endif + endif + + +! Calculate the change in the position vector + + IB=1 + DO 70 I=1,NP + DO 80 J=1,N + DRDT(IB,1,RK)=(FELAS(IB,1)+FPONP(IB,1))/XIR + DRDT(IB,2,RK)=(FELAS(IB,2)+FPONP(IB,2))/XIR + DRDT(IB,3,RK)=(FELAS(IB,3)+FPONP(IB,3))/XIR + DUDT(IB,1,RK)=(TELAS(IB,1)+TPONP(IB,1))/XIU + DUDT(IB,2,RK)=(TELAS(IB,2)+TPONP(IB,2))/XIU + DUDT(IB,3,RK)=(TELAS(IB,3)+TPONP(IB,3))/XIU + + if (BROWN.EQ.0) then + DOTU=DUDT(IB,1,RK)*U(IB,1)+DUDT(IB,2,RK)*U(IB,2)+DUDT(IB,3,RK)*U(IB,3) + DUDT(IB,1,RK)=DUDT(IB,1,RK)-DOTU*U(IB,1) + DUDT(IB,2,RK)=DUDT(IB,2,RK)-DOTU*U(IB,2) + DUDT(IB,3,RK)=DUDT(IB,3,RK)-DOTU*U(IB,3) + endif + IB=IB+1 + 80 CONTINUE + 70 CONTINUE + + if (BROWN.EQ.1) then + IB=1 + DO 90 I=1,NP + DO 100 J=1,N + DRDT(IB,1,RK)=DRDT(IB,1,RK)+FRAND(IB,1)/XIR + DRDT(IB,2,RK)=DRDT(IB,2,RK)+FRAND(IB,2)/XIR + DRDT(IB,3,RK)=DRDT(IB,3,RK)+FRAND(IB,3)/XIR + DUDT(IB,1,RK)=DUDT(IB,1,RK)+TRAND(IB,1)/XIU + DUDT(IB,2,RK)=DUDT(IB,2,RK)+TRAND(IB,2)/XIU + DUDT(IB,3,RK)=DUDT(IB,3,RK)+TRAND(IB,3)/XIU + + DOTU=DUDT(IB,1,RK)*U(IB,1)+DUDT(IB,2,RK)*U(IB,2)+DUDT(IB,3,RK)*U(IB,3) + DUDT(IB,1,RK)=DUDT(IB,1,RK)-DOTU*U(IB,1) + DUDT(IB,2,RK)=DUDT(IB,2,RK)-DOTU*U(IB,2) + DUDT(IB,3,RK)=DUDT(IB,3,RK)-DOTU*U(IB,3) + + IB=IB+1 + 100 CONTINUE + 90 CONTINUE + endif + +! If SIMTYPE=1 (WLC), calculate the constraint forces + + if (SIMTYPE.EQ.1) then + call concalc(R,DRDT,NT,N,NP,XIR,GAM,DT,RK,BROWN) + endif + +! Step forward using the RK algorithm + + call RKstep(RS,R,US,U,DRDT,DUDT,NT,N,NP,RK,DT) + + RK=RK+1 + + ENDDO + + TIME=TIME+DT + +! Swap old variables for new ones + + DT=DT0 + MAGR=sqrt(XIR*2.0/DT) + MAGU=sqrt(XIU*2.0/DT) + + IB=1 + DO 110 I=1,NP + R0(1)=nint(R(IB,1)/LBOX-0.5)*LBOX + R0(2)=nint(R(IB,2)/LBOX-0.5)*LBOX + R0(3)=nint(R(IB,3)/LBOX-0.5)*LBOX + DO 120 J=1,N + R(IB,1)=R(IB,1)-R0(1) + R(IB,2)=R(IB,2)-R0(2) + R(IB,3)=R(IB,3)-R0(3) + RS(IB,1)=R(IB,1) + RS(IB,2)=R(IB,2) + RS(IB,3)=R(IB,3) + US(IB,1)=U(IB,1) + US(IB,2)=U(IB,2) + US(IB,3)=U(IB,3) + IB=IB+1 + 120 CONTINUE + 110 CONTINUE + + ENDDO + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/BDcode/RKstep.f90 b/BasicWLC/BDcode/RKstep.f90 new file mode 100644 index 00000000..70753804 --- /dev/null +++ b/BasicWLC/BDcode/RKstep.f90 @@ -0,0 +1,72 @@ +!---------------------------------------------------------------* + +! +! This subroutine performs the RK step for user inputted timestep +! size +! +! Andrew Spakowitz +! Written 6-6-04 + + SUBROUTINE RKstep(RS,R,US,U,DRDT,DUDT,NT,N,NP,RK,DT) + + PARAMETER (PI=3.141592654) ! Value of pi + + DOUBLE PRECISION RS(NT,3) ! Saved bead positions + DOUBLE PRECISION R(NT,3) ! Temp bead positions + DOUBLE PRECISION US(NT,3) ! Unit tangent + DOUBLE PRECISION U(NT,3) ! Unit tangent + DOUBLE PRECISION DRDT(NT,3,4) ! Change rate of beads + DOUBLE PRECISION DUDT(NT,3,4) ! Change rate of beads + DOUBLE PRECISION DT ! Time step size + INTEGER N,NT ! Bead numbers + INTEGER RK ! RK number + INTEGER I,J,IB ! Index number + DOUBLE PRECISION MAGU + + IB=1 + DO 10 I=1,NP + DO 20 J=1,N + if(RK.EQ.1) then + R(IB,1)=RS(IB,1)+DT*DRDT(IB,1,RK)/2. + R(IB,2)=RS(IB,2)+DT*DRDT(IB,2,RK)/2. + R(IB,3)=RS(IB,3)+DT*DRDT(IB,3,RK)/2. + U(IB,1)=US(IB,1)+DT*DUDT(IB,1,RK)/2. + U(IB,2)=US(IB,2)+DT*DUDT(IB,2,RK)/2. + U(IB,3)=US(IB,3)+DT*DUDT(IB,3,RK)/2. + elseif(RK.EQ.2) then + R(IB,1)=RS(IB,1)+DT*DRDT(IB,1,RK)/2. + R(IB,2)=RS(IB,2)+DT*DRDT(IB,2,RK)/2. + R(IB,3)=RS(IB,3)+DT*DRDT(IB,3,RK)/2. + U(IB,1)=US(IB,1)+DT*DUDT(IB,1,RK)/2. + U(IB,2)=US(IB,2)+DT*DUDT(IB,2,RK)/2. + U(IB,3)=US(IB,3)+DT*DUDT(IB,3,RK)/2. + elseif(RK.EQ.3) then + R(IB,1)=RS(IB,1)+DT*DRDT(IB,1,RK) + R(IB,2)=RS(IB,2)+DT*DRDT(IB,2,RK) + R(IB,3)=RS(IB,3)+DT*DRDT(IB,3,RK) + U(IB,1)=US(IB,1)+DT*DUDT(IB,1,RK) + U(IB,2)=US(IB,2)+DT*DUDT(IB,2,RK) + U(IB,3)=US(IB,3)+DT*DUDT(IB,3,RK) + elseif(RK.EQ.4) then + R(IB,1)=RS(IB,1)+DT*(DRDT(IB,1,1)/6.+DRDT(IB,1,2)/3.+DRDT(IB,1,3)/3.+DRDT(IB,1,4)/6.) + R(IB,2)=RS(IB,2)+DT*(DRDT(IB,2,1)/6.+DRDT(IB,2,2)/3.+DRDT(IB,2,3)/3.+DRDT(IB,2,4)/6.) + R(IB,3)=RS(IB,3)+DT*(DRDT(IB,3,1)/6.+DRDT(IB,3,2)/3.+DRDT(IB,3,3)/3.+DRDT(IB,3,4)/6.) + U(IB,1)=US(IB,1)+DT*(DUDT(IB,1,1)/6.+DUDT(IB,1,2)/3.+DUDT(IB,1,3)/3.+DUDT(IB,1,4)/6.) + U(IB,2)=US(IB,2)+DT*(DUDT(IB,2,1)/6.+DUDT(IB,2,2)/3.+DUDT(IB,2,3)/3.+DUDT(IB,2,4)/6.) + U(IB,3)=US(IB,3)+DT*(DUDT(IB,3,1)/6.+DUDT(IB,3,2)/3.+DUDT(IB,3,3)/3.+DUDT(IB,3,4)/6.) + endif + + MAGU=sqrt(U(IB,1)**2.+U(IB,2)**2.+U(IB,3)**2.) + U(IB,1)=U(IB,1)/MAGU + U(IB,2)=U(IB,2)/MAGU + U(IB,3)=U(IB,3)/MAGU + + IB=IB+1 + 20 CONTINUE + 10 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* + diff --git a/BasicWLC/BDcode/calc_dist.f90 b/BasicWLC/BDcode/calc_dist.f90 new file mode 100644 index 00000000..b0fd5c9b --- /dev/null +++ b/BasicWLC/BDcode/calc_dist.f90 @@ -0,0 +1,20 @@ +subroutine calc_dist(r,nt,fpt_dist,in_rxn_rad,k1,k2) + implicit none + integer :: i + double precision :: d, distance + integer, intent(in) :: nt, in_rxn_rad(nt,nt), k1 + double precision, intent(in) :: r(nt,3), fpt_dist + integer,intent(out) :: k2 + ! when more than 2 beads are within reaction distance, find the 2 that are closest together + distance = fpt_dist + do i = 1, nt + if ((in_rxn_rad(k1,i).eq.1) .and. (k1.ne.i)) then + d = sqrt(((r(k1,1)-r(i,1))**2)+((r(k1,2)-r(i,2))**2)+((r(k1,3)-r(i,3))**2)) + if (d.lt.distance) then + distance = d + k2 = i + end if + end if + end do +end + diff --git a/BasicWLC/BDcode/check_reactions.f90 b/BasicWLC/BDcode/check_reactions.f90 new file mode 100644 index 00000000..157e1d4b --- /dev/null +++ b/BasicWLC/BDcode/check_reactions.f90 @@ -0,0 +1,58 @@ +subroutine check_reactions(r, nt, meth_status, in_rxn_rad, could_react, fpt_dist, pairs) + implicit none + integer, intent(in) :: meth_status(nt) + double precision, intent(inout) :: r(nt,3), fpt_dist + double precision :: check_pair(nt,nt) + integer, intent(inout) :: could_react, nt, in_rxn_rad(nt,nt), pairs(2,nt) + integer :: k1,k2 + + ! initialize variables + do k1 = 1, nt + do k2 = 1, nt + check_pair(k1,k2) = 0 + end do + end do + + do k1 = 1, nt + pairs(1,k1) = 0 + pairs(2,k1) = 0 + end do + + ! for pairs of beads that are close enough to react, check that one + ! is methylated and one unmethylated + do k1 = 1, nt + if (sum(in_rxn_rad(k1,:)).eq.1) then + k2 = maxloc(in_rxn_rad(k1,:),1) + if (check_pair(k1,k2).eq.0) then + check_pair(k1,k2) = 1 + check_pair(k2,k1) = 1 + if (meth_status(k1).eq.1 .and. meth_status(k2).eq.0) then + could_react = could_react + 1 + pairs(1,could_react) = k1 + pairs(2,could_react) = k2 + else if (meth_status(k1).eq.0 .and. meth_status(k2).eq.1) then + could_react = could_react + 1 + pairs(1,could_react) = k2 + pairs(2,could_react) = k1 + end if + end if + else if (sum(in_rxn_rad(k1,:)).gt.1) then + call calc_dist(r,nt,fpt_dist,in_rxn_rad,k1,k2) + if (check_pair(k1,k2).eq.0) then + check_pair(k1,k2) = 1 + check_pair(k2,k1) = 1 + if ((meth_status(k1).eq.1) .and. (meth_status(k2).eq.0)) then + could_react = could_react + 1 + pairs(1,could_react) = k1 + pairs(2,could_react) = k2 + else if ((meth_status(k1).eq.0) .and. (meth_status(k2).eq.1)) then + could_react = could_react + 1 + pairs(1,could_react) = k2 + pairs(2,could_react) = k1 + end if + end if + end if + end do +end + + diff --git a/BasicWLC/BDcode/colchecker.f90 b/BasicWLC/BDcode/colchecker.f90 new file mode 100644 index 00000000..8b5c4bcc --- /dev/null +++ b/BasicWLC/BDcode/colchecker.f90 @@ -0,0 +1,266 @@ + +subroutine insertion_sort(n,a) + implicit none + integer n,i,j + double precision a(n),x + do 30 i=2,n + x=a(i) + j=i +10 j=j-1 + if (j.eq.0 .or. a(j).le.x) go to 20 + a(j+1)=a(j) + go to 10 +20 a(j+1)=x +30 continue +end + +subroutine check_collisions(r, nt, has_collided, fpt_dist, time, col_type, in_rxn_rad) + implicit none + integer, intent(in) :: nt, col_type + double precision, intent(in) :: fpt_dist, time + double precision, intent(in) :: r(nt,3) + double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) + + if (col_type.eq.0) then + return + else if (col_type.eq.1) then + call check_collisions_brute(r, nt, has_collided, fpt_dist, time, in_rxn_rad) + else if (col_type.eq.2) then + call check_collisions_kd(r, nt, has_collided, fpt_dist, time) + else if (col_type.eq.3) then + call check_collisions_bb(r, nt, has_collided, fpt_dist, time, in_rxn_rad) + end if +end + +subroutine check_collisions_brute(r, nt, has_collided, fpt_dist, & + time, in_rxn_rad) + implicit none + + integer, intent(in) :: nt + integer k1, k2 + double precision, intent(in) :: fpt_dist, time, r(nt,3) + double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) + + + !integer nt, in_rxn_rad(nt,nt),k1,k2 + !double precision fpt_dist, time + !double precision r(nt,3), has_collided(nt, nt) + + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + + ! check if the particles have collided + do k1 = 1, nt + do k2 = 1, nt + if ((k1.ne.k2) & + .and. (abs(r(k1,1) - r(k2,1)) < fpt_dist) & + .and. (abs(r(k1,2) - r(k2,2)) < fpt_dist) & + .and. (abs(r(k1,3) - r(k2,3)) < fpt_dist)) then + in_rxn_rad(k1,k2) = 1 + if (has_collided(k1,k2).lt.0.0d0) then + has_collided(k1,k2) = time + end if + end if + end do + end do +end + +subroutine check_collisions_kd(r, nt, has_collided, fpt_dist, time) + use kdtree2_module, only : kdtree2, kdtree2_result, kdtree2_create, & + kdtree2_r_nearest_around_point + implicit none + integer nt, nfound, nalloc, k1, k2, i, in_rxn_rad(nt,nt) + double precision fpt_dist, time + double precision r(nt,3), has_collided(nt, nt) + type(kdtree2), pointer :: col_tree + type(kdtree2_result), allocatable :: kd_results(:) + + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + + col_tree => kdtree2_create(r, rearrange = .true., sort = .false.) + do k1 = 1,nt + call kdtree2_r_nearest_around_point(col_tree, idxin = k1, & + correltime = 1, r2 = fpt_dist, nfound = nfound, nalloc = nalloc, & + results = kd_results) + do i = 1,nfound + k2 = kd_results(i)%idx + in_rxn_rad(k1,k2) = 1 + if (has_collided(k1,k2) .lt. 0) then + has_collided(k1,k2) = time + endif + enddo + enddo +end + +subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time, in_rxn_rad) +! at each time point, we want to have 2 "pointer arrays", ind & indi +! r(ind(:,k),k) is in order for k in 1,2,3 i.e. [~,ind(:,1)] = sort(r(:,1) +! ind(indi(i,k),k) == i for k in 1,2,3 +! at all time points +! +! acf means "after collision found" with ith bead in dimension d + use, intrinsic :: iso_fortran_env + implicit none + integer, parameter :: dp = REAL64 + + integer, intent(in) :: nt + double precision, intent(in) :: fpt_dist, time, r(nt,3) + double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) + + integer :: neighbors(nt,nt) ! most of array won't be used, probably + ! neighbors(1:num_neighbors(i),i) holds neighbors of bead i for each i + ! acf: neighbors(?,i) = j iff found in all three (d == 3, neighbor_triplet_keeper(j) == 2/3) + integer :: num_neighbors(nt) ! to prevent O(nt^2) access to neighbors + ! acf: num_neighbors(i)++ iff found in all three (d == 3, neighbor_triplet_keeper(j) == 2/3) + integer :: neighbor_triplet_keeper(nt) ! O(nt)-space "hash table" + ! every time we find that bead j is a neighbor in one of the three + ! dimensions, then we increment neighbor_triplet_keeper(j), until we + ! realize it's not a neighbor in one of the dimensions, or that it is + ! in all three + ! acf: neighbor_triplet_keeper(j)++ + integer :: neighbor_zeroer(nt), num_zeros ! to zero out "hash table" quickly + ! reports that neighbor_triplet_keeper(neighbor_zeroer(1:num_zeros)) + ! should be zeroed after checking for all the neighbors of a particular + ! bead + ! acf: neighbor_zeroer(++num_zeros) = j if neighbor_triplet_keeper == 0/1 + ! better: "" "" if d == 1 (i.e. we're adding j to triplet array) + integer, save, allocatable, dimension(:,:) :: ind, indi + integer, save :: is_allocated = 0 ! "static" variable, allow initial setup + integer :: curr_indi, curr_ind, i, j, d, rd0, k1, k2 + double precision :: rneighbor + + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + + ! initialize ind and indi on first pass, requires O(n log n) sort + if (is_allocated == 0) then + is_allocated = 1 + allocate(ind(nt,3)) + allocate(indi(nt,3)) + do d = 1, 3 + do i = 1, nt + ind(i,d) = i + indi(i,d) = i + enddo + call qcolsort(nt, indi(:,d), ind(:,d), r(:,d)) + enddo + ! ind and indi should satisfy desired property + else + do d = 1, 3 + call icolsort(nt, indi(:,d), ind(:,d), r(:,d)) + enddo + endif + ! initialize loop variables + num_zeros = 0 + do i = 1, nt + num_neighbors(i) = 0 + neighbor_triplet_keeper(i) = 0 + neighbor_zeroer(i) = 0 + enddo + ! fills neighbors(:,i) with num_neighbors(i) indices of particles that the + ! ith particle has collided with + do i = 1, nt + ! look at three dimensions one-by-one + do d = 1, 3 + curr_indi = indi(i,d) + curr_ind = ind(curr_indi,d) + rd0 = r(curr_ind,d) + ! first we're going to look for particles to the "right" + j = 1 + if (curr_indi == nt) exit + curr_ind = ind(curr_indi + j,d) + rneighbor = r(curr_ind,d) + do while (rneighbor < rd0 + fpt_dist) +! on the first pass, just mark that a collision happened in this coord +! then mark that index in the "hash table" as "needs zeroing" + if (d == 1) then + num_zeros = num_zeros + 1 + neighbor_zeroer(num_zeros) = curr_ind + ! basically do: neighbor_triplet_keeper(curr_ind) = neighbor_triplet_keeper(curr_ind) + 1 + neighbor_triplet_keeper(curr_ind) = 1 +! on the second pass, only mark if it also happened on the first pass + elseif (d == 2) then + if (neighbor_triplet_keeper(curr_ind) == 1) then + ! basically do: neighbor_triplet_keeper(curr_ind) = neighbor_triplet_keeper(curr_ind) + 1 + neighbor_triplet_keeper(curr_ind) = 2 + endif +! on the third pass, make the ones that have hit the official colliders + else ! (d == 3) + if (neighbor_triplet_keeper(curr_ind) == 2) then + num_neighbors(i) = num_neighbors(i) + 1 + neighbors(num_neighbors(i),i) = curr_ind + endif + endif + j = j + 1 + if (curr_indi + j > nt) exit + curr_ind = ind(curr_indi + j,d) + rneighbor = r(curr_ind,d) + enddo + ! now we look for particles to the "left" + j = 1 + if (curr_indi == 1) exit + curr_ind = ind(curr_indi - j,d) + rneighbor = r(curr_ind,d) + do while (rneighbor > rd0 - fpt_dist) +! on the first pass, just mark that a collision happened in this coord +! then mark that index in the "hash table" as "needs zeroing" + if (d == 1) then + num_zeros = num_zeros + 1 + neighbor_zeroer(num_zeros) = curr_ind + ! basically do: neighbor_triplet_keeper(curr_ind) = neighbor_triplet_keeper(curr_ind) + 1 + neighbor_triplet_keeper(curr_ind) = 1 +! on the second pass, only mark if it also happened on the first pass + elseif (d == 2) then + if (neighbor_triplet_keeper(curr_ind) == 1) then + ! basically do: neighbor_triplet_keeper(curr_ind) = neighbor_triplet_keeper(curr_ind) + 1 + neighbor_triplet_keeper(curr_ind) = 2 + endif +! on the third pass, make the ones that have hit the official colliders + else ! (d == 3) + if (neighbor_triplet_keeper(curr_ind) == 2) then + num_neighbors(i) = num_neighbors(i) + 1 + neighbors(num_neighbors(i),i) = curr_ind + endif + endif + j = j + 1 + if (curr_indi - j < 1) exit + curr_ind = ind(curr_indi - j,d) + rneighbor = r(curr_ind,d) + enddo + enddo + ! zero out the "hash table" + ! might be faster to sort neighbors to zero or zero entire thing for small nt? + ! should probably check this at some point + do j = 1, num_zeros + neighbor_triplet_keeper(neighbor_zeroer(j)) = 0 + enddo + num_zeros = 0 + enddo + ! from the neighbors, num_neighbors arrays, we can rapidly extract + ! exactly those elements that have collided + ! neighbors(neighborj, beadi), num_neighbors(beadi) + do i = 1, nt + do j = 1, num_neighbors(i) + in_rxn_rad(i,neighbors(j,i)) = 1 + if (has_collided(neighbors(j,i),i) < 0.0_dp) then + has_collided(neighbors(j,i),i) = time + endif + enddo + enddo +end diff --git a/BasicWLC/BDcode/colsort.f90 b/BasicWLC/BDcode/colsort.f90 new file mode 100644 index 00000000..ed90cda1 --- /dev/null +++ b/BasicWLC/BDcode/colsort.f90 @@ -0,0 +1,43 @@ +!--------------------------------------------------------------- +! Sort an index-array and an index-index array by a double array target +!--------------------------------------------------------------- + +! use quicksort +subroutine qcolsort(array_size, indexi, index, value) + implicit none + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: QSORT_THRESHOLD = 32 + integer, intent(in) :: array_size + integer, intent(inout) :: index(array_size) + integer, intent(inout) :: indexi(array_size) + real(dp), intent(in) :: value(array_size) + + include "qsort_inline.inc" +contains + include "colsort.inc" +end subroutine qcolsort + +! use insertion sort +subroutine icolsort(array_size, indexi, index, value) + implicit none + integer, parameter :: dp = selected_real_kind(15, 307) + integer, intent(in) :: array_size + integer, intent(inout) :: index(array_size) + integer, intent(inout) :: indexi(array_size) + real(dp), intent(in) :: value(array_size) + + integer :: left, right + do right = 2, array_size + left = right - 1 + if (less_than(right, left)) then + do ! need two separate if's since fortran has no short circuit "&&" + if (left < 2) exit + if (.NOT.less_than(right, left - 1)) exit + left = left - 1 + enddo + call rshift(left, right) + endif + enddo +contains + include "colsort.inc" +end subroutine icolsort diff --git a/BasicWLC/BDcode/colsort.inc b/BasicWLC/BDcode/colsort.inc new file mode 100644 index 00000000..13d8c332 --- /dev/null +++ b/BasicWLC/BDcode/colsort.inc @@ -0,0 +1,56 @@ +! helper routines for sorting an array ind based on an array r, while keeping a +! third array indi such that: +! r(ind(:,k),k) is in order for k in 1,2,3 i.e. [~,ind(:,1)] = sort(r(:,1) +! ind(indi(i,k),k) == i for k in 1,2,3 +! (indi(:,k) == indexi, ind(:,k) == index, r(:,k) == value +! +! in reasoning about the following, it is useful to note that ind and indi as +! functions from 1,n to 1,n are inverses: indi(ind(i)) == i && ind(indi(i)) == i + + ! do-nothing initialization routine required for qsort_inline.inc + subroutine init() + end subroutine init + + ! swap indices a,b + subroutine swap(a,b) + ! less_than(index(a),index(b)) will lead to a swap + integer, intent(in) :: a,b + integer :: hold + hold=index(a) + index(a)=index(b) + index(b)=hold + ! easy to see this is what you want if you know you want to make + ! indexi the inverse of index (as a function from N to N) + indexi(index(a)) = a + indexi(index(b)) = b + end subroutine swap + + ! circular shift-right by one: + subroutine rshift(left,right) + implicit none + integer, intent(in) :: left, right + integer :: hold, i + hold=index(right) + ! This syntax is valid, but has poor optimization in GFortran: + ! index(left+1:right)=index(left:right-1) + do i=right,left+1,-1 + index(i)=index(i-1) + end do + index(left)=hold + do i=left,right + indexi(index(i)) = indexi(index(i)) + 1 + end do + indexi(hold) = left + end subroutine rshift + + ! fuzzy comparator prevents unecessary switching in super-fine time steps + logical & + function less_than(a,b) + integer, intent(in) :: a,b +! real(dp), parameter :: small=1.0e-15 +! if ( abs(value(index(a))-value(index(b))) < small ) then +! less_than = index(a) < index(b) +! else + less_than = value(index(a)) < value(index(b)) +! end if + end function less_than diff --git a/BasicWLC/BDcode/concalc.f90 b/BasicWLC/BDcode/concalc.f90 new file mode 100644 index 00000000..f00f5156 --- /dev/null +++ b/BasicWLC/BDcode/concalc.f90 @@ -0,0 +1,176 @@ +!---------------------------------------------------------------* + +! +! This subroutine performs the constraint forces +! +! Andrew Spakowitz +! Written 9-8-04 + + SUBROUTINE concalc(R,DRDT,NT,N,NP,XI,L0,DT,RK,BROWN) + +! Variables from the simulation + + DOUBLE PRECISION DRDT(NT,3,4) ! Rate of change + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(N-1,3) ! Unit tangent vector + DOUBLE PRECISION B(N-1) ! Bond length + INTEGER N,NT,NP ! Number of beads + DOUBLE PRECISION DT ! Time step size + DOUBLE PRECISION XI ! Drag coefficient + DOUBLE PRECISION L0 ! Bond distances + INTEGER I,J,IB ! Index holder + INTEGER RK ! RK integer + INTEGER BROWN ! Logic for BD forces + +! Variables for use in the constraint calculation + + DOUBLE PRECISION BLAM(N-1),ADIAG(N-1) + DOUBLE PRECISION ASUPER(N-1),ASUB(N-1) + DOUBLE PRECISION STDEV,C + INTEGER INFO + +! Variables of use in the pseudopotential calculation + + DOUBLE PRECISION FPS(N,3),APS(N-1),BPS(N-2) + DOUBLE PRECISION DETLT(N-1),DETGT(N-1),DETER + +! Relaxation parameter + + C = 0.1/DT + +! Calculate the bond length and tangent vectors + + DO 5 J=1,NP + IB=N*(J-1) + + DO 10 I=1,(N-1) + U(I,1)=R(I+IB+1,1)-R(I+IB,1) + U(I,2)=R(I+IB+1,2)-R(I+IB,2) + U(I,3)=R(I+IB+1,3)-R(I+IB,3) + B(I)=sqrt(U(I,1)**2.+U(I,2)**2.+U(I,3)**2.) + U(I,1)=U(I,1)/B(I) + U(I,2)=U(I,2)/B(I) + U(I,3)=U(I,3)/B(I) + 10 CONTINUE + +! Setup the A component + + DO 15 I=1,(N-1) + ADIAG(I) = 2.*B(I)*B(I) + if (BROWN.EQ.1) then + APS(I)=ADIAG(I) + endif + if (I.GE.2) then + ASUB(I)=-B(I)*B(I-1)*(U(I,1)*U(I-1,1)+ & + U(I,2)*U(I-1,2)+U(I,3)*U(I-1,3)) + ASUPER(I-1)=ASUB(I) + if (BROWN.EQ.1) then + BPS(I-1)=ASUPER(I-1) + endif + endif +15 CONTINUE + ASUB(1)=0. + ASUPER(N-1)=0. + +! Calculate psuedo-potential (if Brownian forces on) + + if (BROWN.EQ.1) then + DETLT(1)=1.0 + DETLT(2)=APS(1) + DETGT(N-1)=1.0 + DETGT(N-2)=APS(N-1) + DO 20 I=3,(N-1) + DETLT(I)=APS(I-1)*DETLT(I-1)- & + BPS(I-2)*BPS(I-2)*DETLT(I-2) + DETGT(N-I)=APS(N-I+1)*DETGT(N-I+1)- & + BPS(N-I+1)*BPS(N-I+1)*DETGT(N-I+2) + 20 CONTINUE + DETER=APS(N-1)*DETLT(N-1)-BPS(N-2)*BPS(N-2)*DETLT(N-2) + + FPS(1,1)=DETGT(2)*BPS(1)*B(2)*U(2,1)/DETER + FPS(1,2)=DETGT(2)*BPS(1)*B(2)*U(2,2)/DETER + FPS(1,3)=DETGT(2)*BPS(1)*B(2)*U(2,3)/DETER + FPS(2,1)=DETGT(2)*BPS(1)*(B(1)*U(1,1)- & + B(2)*U(2,1))/DETER+ & + DETGT(3)*APS(1)*BPS(2)*B(3)*U(3,1)/DETER + FPS(2,2)=DETGT(2)*BPS(1)*(B(1)*U(1,2)- & + B(2)*U(2,2))/DETER+ & + DETGT(3)*APS(1)*BPS(2)*B(3)*U(3,2)/DETER + FPS(2,3)=DETGT(2)*BPS(1)*(B(1)*U(1,3)- & + B(2)*U(2,3))/DETER+ & + DETGT(3)*APS(1)*BPS(2)*B(3)*U(3,3)/DETER + DO 30 I=3,(N-2) + FPS(I,1)=(DETLT(I-1)*DETGT(I)*BPS(I-1)*(-B(I)*U(I,1)+B(I-1)*U(I-1,1))+ & + DETLT(I-1)*DETGT(I+1)*APS(I-1)*BPS(I)*B(I+1)*U(I+1,1)- & + DETLT(I-2)*DETGT(I)*APS(I)*BPS(I-2)*B(I-2)*U(I-2,1)- & + DETLT(I-2)*DETGT(I+1)*( & + (BPS(I-2)**2.)*BPS(I)*B(I+1)*U(I+1,1)- & + (BPS(I)**2.)*BPS(I-2)*B(I-2)*U(I-2,1)))/DETER + FPS(I,2)=(DETLT(I-1)*DETGT(I)*BPS(I-1)*(-B(I)*U(I,2)+B(I-1)*U(I-1,2))+ & + DETLT(I-1)*DETGT(I+1)*APS(I-1)*BPS(I)*B(I+1)*U(I+1,2)- & + DETLT(I-2)*DETGT(I)*APS(I)*BPS(I-2)*B(I-2)*U(I-2,2)- & + DETLT(I-2)*DETGT(I+1)*( & + (BPS(I-2)**2.)*BPS(I)*B(I+1)*U(I+1,2)- & + (BPS(I)**2.)*BPS(I-2)*B(I-2)*U(I-2,2)))/DETER + FPS(I,3)=(DETLT(I-1)*DETGT(I)*BPS(I-1)*(-B(I)*U(I,3)+B(I-1)*U(I-1,3))+ & + DETLT(I-1)*DETGT(I+1)*APS(I-1)*BPS(I)*B(I+1)*U(I+1,3)- & + DETLT(I-2)*DETGT(I)*APS(I)*BPS(I-2)*B(I-2)*U(I-2,3)- & + DETLT(I-2)*DETGT(I+1)*( & + (BPS(I-2)**2.)*BPS(I)*B(I+1)*U(I+1,3)- & + (BPS(I)**2.)*BPS(I-2)*B(I-2)*U(I-2,3)))/DETER + 30 CONTINUE + FPS(N-1,1)=DETLT(N-2)*BPS(N-2)*(-B(N-1)*U(N-1,1)+ & + B(N-2)*U(N-2,1))/DETER- & + DETLT(N-3)*APS(N-1)*BPS(N-3)*B(N-3)*U(N-3,1)/DETER + FPS(N-1,2)=DETLT(N-2)*BPS(N-2)*(-B(N-1)*U(N-1,2)+ & + B(N-2)*U(N-2,2))/DETER- & + DETLT(N-3)*APS(N-1)*BPS(N-3)*B(N-3)*U(N-3,2)/DETER + FPS(N-1,3)=DETLT(N-2)*BPS(N-2)*(-B(N-1)*U(N-1,3)+ & + B(N-2)*U(N-2,3))/DETER- & + DETLT(N-3)*APS(N-1)*BPS(N-3)*B(N-3)*U(N-3,3)/DETER + FPS(N,1)=-DETLT(N-2)*BPS(N-2)*B(N-2)*U(N-2,1)/DETER + FPS(N,2)=-DETLT(N-2)*BPS(N-2)*B(N-2)*U(N-2,2)/DETER + FPS(N,3)=-DETLT(N-2)*BPS(N-2)*B(N-2)*U(N-2,3)/DETER + + DO 35 I=1,N + DRDT(I+IB,1,RK)=DRDT(I+IB,1,RK)+FPS(I,1)/XI + DRDT(I+IB,2,RK)=DRDT(I+IB,2,RK)+FPS(I,2)/XI + DRDT(I+IB,3,RK)=DRDT(I+IB,3,RK)+FPS(I,3)/XI + 35 CONTINUE + endif + + +! Setup the B component + + DO 40 I=1,(N-1) + BLAM(I)=B(I)*XI*(U(I,1)*(DRDT(I+1+IB,1,RK)-DRDT(I+IB,1,RK))+ & + U(I,2)*(DRDT(I+1+IB,2,RK)-DRDT(I+IB,2,RK))+ & + U(I,3)*(DRDT(I+1+IB,3,RK)-DRDT(I+IB,3,RK)))+ & + XI*C*(B(I)**.2-L0**2.) + 40 CONTINUE + +! Calculate the new rates of change + + call DGTSV((N-1),1,ASUB,ADIAG,ASUPER,BLAM,(N-1),INFO) + + DRDT(1+IB,1,RK)=DRDT(1+IB,1,RK)+BLAM(1)*B(1)*U(1,1)/XI + DRDT(1+IB,2,RK)=DRDT(1+IB,2,RK)+BLAM(1)*B(1)*U(1,2)/XI + DRDT(1+IB,3,RK)=DRDT(1+IB,3,RK)+BLAM(1)*B(1)*U(1,3)/XI + DO 50 I=2,(N-1) + DRDT(I+IB,1,RK)=DRDT(I+IB,1,RK)+(BLAM(I)*B(I)*U(I,1)- & + BLAM(I-1)*B(I-1)*U(I-1,1))/XI + DRDT(I+IB,2,RK)=DRDT(I+IB,2,RK)+(BLAM(I)*B(I)*U(I,2)- & + BLAM(I-1)*B(I-1)*U(I-1,2))/XI + DRDT(I+IB,3,RK)=DRDT(I+IB,3,RK)+(BLAM(I)*B(I)*U(I,3)- & + BLAM(I-1)*B(I-1)*U(I-1,3))/XI + 50 CONTINUE + DRDT(N+IB,1,RK)=DRDT(N+IB,1,RK)-BLAM(N-1)*B(N-1)*U(N-1,1)/XI + DRDT(N+IB,2,RK)=DRDT(N+IB,2,RK)-BLAM(N-1)*B(N-1)*U(N-1,2)/XI + DRDT(N+IB,3,RK)=DRDT(N+IB,3,RK)-BLAM(N-1)*B(N-1)*U(N-1,3)/XI + + 5 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/BDcode/force_elas.f90 b/BasicWLC/BDcode/force_elas.f90 new file mode 100644 index 00000000..1e9cbcd9 --- /dev/null +++ b/BasicWLC/BDcode/force_elas.f90 @@ -0,0 +1,171 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the elastic forces for a wormlike +! chain with a stretching potential. The stretch and bend +! moduli are fed along with the bead positions. +! +! Andrew Spakowitz +! Written 9-1-04 + + SUBROUTINE force_elas(FELAS,TELAS,R,U,NT,N,NP, & + EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + + DOUBLE PRECISION FELAS(NT,3) ! Elastic force + DOUBLE PRECISION TELAS(NT,3) ! Elastic force + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION B(NT) ! Bond lengths + INTEGER I,J,IB ! Index holders + INTEGER N,NT,NP ! Number of bead + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Polymer properties + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + +! Variables for force and torque calculations + + DOUBLE PRECISION DR(3),DRPAR,DRPERP(3) + DOUBLE PRECISION FI(3),TI1(3),TI2(3) + DOUBLE PRECISION U1U2,GI(3),HI(3) + + IB=1 + DO 10 I=1,NP + DO 20 J=1,N + FELAS(IB,1)=0. + FELAS(IB,2)=0. + FELAS(IB,3)=0. + TELAS(IB,1)=0. + TELAS(IB,2)=0. + TELAS(IB,3)=0. + if (SIMTYPE.EQ.1.AND.J.LE.(N-1)) then + U(IB,1)=R(IB+1,1)-R(IB,1) + U(IB,2)=R(IB+1,2)-R(IB,2) + U(IB,3)=R(IB+1,3)-R(IB,3) + B(IB)=sqrt(U(IB,1)**2.+U(IB,2)**2.+U(IB,3)**2.) + U(IB,1)=U(IB,1)/B(IB) + U(IB,2)=U(IB,2)/B(IB) + U(IB,3)=U(IB,3)/B(IB) + endif + IB=IB+1 + + 20 CONTINUE + 10 CONTINUE + +! Calculate the forces and torques + + DO 30 I=1,NP + DO 40 J=1,(N-1) + IB=J+N*(I-1) + if (SIMTYPE.EQ.1) then + + if (J.LE.(N-2)) then + + U1U2=U(IB,1)*U(IB+1,1)+U(IB,2)*U(IB+1,2)+U(IB,3)*U(IB+1,3) + + GI(1)=EB*(U(IB+1,1)-U1U2*U(IB,1))/B(IB) + GI(2)=EB*(U(IB+1,2)-U1U2*U(IB,2))/B(IB) + GI(3)=EB*(U(IB+1,3)-U1U2*U(IB,3))/B(IB) + + FELAS(IB,1)=FELAS(IB,1)-GI(1) + FELAS(IB,2)=FELAS(IB,2)-GI(2) + FELAS(IB,3)=FELAS(IB,3)-GI(3) + FELAS(IB+1,1)=FELAS(IB+1,1)+GI(1) + FELAS(IB+1,2)=FELAS(IB+1,2)+GI(2) + FELAS(IB+1,3)=FELAS(IB+1,3)+GI(3) + + GI(1)=EB*(U(IB,1)-U1U2*U(IB+1,1))/B(IB+1) + GI(2)=EB*(U(IB,2)-U1U2*U(IB+1,2))/B(IB+1) + GI(3)=EB*(U(IB,3)-U1U2*U(IB+1,3))/B(IB+1) + + FELAS(IB+1,1)=FELAS(IB+1,1)-GI(1) + FELAS(IB+1,2)=FELAS(IB+1,2)-GI(2) + FELAS(IB+1,3)=FELAS(IB+1,3)-GI(3) + FELAS(IB+2,1)=FELAS(IB+2,1)+GI(1) + FELAS(IB+2,2)=FELAS(IB+2,2)+GI(2) + FELAS(IB+2,3)=FELAS(IB+2,3)+GI(3) + + endif + TELAS(IB,1)=0. + TELAS(IB,2)=0. + TELAS(IB,3)=0. + TELAS(IB+1,1)=0. + TELAS(IB+1,2)=0. + TELAS(IB+1,3)=0. + + elseif (SIMTYPE.EQ.2) then + DR(1)=R(IB+1,1)-R(IB,1) + DR(2)=R(IB+1,2)-R(IB,2) + DR(3)=R(IB+1,3)-R(IB,3) + DRPAR=DR(1)*U(IB,1)+DR(2)*U(IB,2)+DR(3)*U(IB,3) + + DRPERP(1)=DR(1)-DRPAR*U(IB,1) + DRPERP(2)=DR(2)-DRPAR*U(IB,2) + DRPERP(3)=DR(3)-DRPAR*U(IB,3) + U1U2=U(IB,1)*U(IB+1,1)+U(IB,2)*U(IB+1,2)+U(IB,3)*U(IB+1,3) + + GI(1)=U(IB+1,1)-U1U2*U(IB,1)-ETA*DRPERP(1) + GI(2)=U(IB+1,2)-U1U2*U(IB,2)-ETA*DRPERP(2) + GI(3)=U(IB+1,3)-U1U2*U(IB,3)-ETA*DRPERP(3) + + FI(1)=-ETA*EB*GI(1)+EPAR*(DRPAR-GAM)*U(IB,1)+EPERP*DRPERP(1) + FI(2)=-ETA*EB*GI(2)+EPAR*(DRPAR-GAM)*U(IB,2)+EPERP*DRPERP(2) + FI(3)=-ETA*EB*GI(3)+EPAR*(DRPAR-GAM)*U(IB,3)+EPERP*DRPERP(3) + + FELAS(IB,1)=FELAS(IB,1)+FI(1) + FELAS(IB,2)=FELAS(IB,2)+FI(2) + FELAS(IB,3)=FELAS(IB,3)+FI(3) + FELAS(IB+1,1)=FELAS(IB+1,1)-FI(1) + FELAS(IB+1,2)=FELAS(IB+1,2)-FI(2) + FELAS(IB+1,3)=FELAS(IB+1,3)-FI(3) + + GI(1)=U(IB+1,1)-U(IB,1)-ETA*DRPERP(1) + GI(2)=U(IB+1,2)-U(IB,2)-ETA*DRPERP(2) + GI(3)=U(IB+1,3)-U(IB,3)-ETA*DRPERP(3) + + TI1(1)=EB*GI(1) + TI1(2)=EB*GI(2) + TI1(3)=EB*GI(3) + + TI2(1)=-ETA*EB*DRPAR*GI(1)+ETA*EB*(1-U1U2)*DR(1)-EPAR*(DRPAR-GAM)*DR(1)+EPERP*DRPAR*DRPERP(1) + TI2(2)=-ETA*EB*DRPAR*GI(2)+ETA*EB*(1-U1U2)*DR(2)-EPAR*(DRPAR-GAM)*DR(2)+EPERP*DRPAR*DRPERP(2) + TI2(3)=-ETA*EB*DRPAR*GI(3)+ETA*EB*(1-U1U2)*DR(3)-EPAR*(DRPAR-GAM)*DR(3)+EPERP*DRPAR*DRPERP(3) + + TELAS(IB,1)=TELAS(IB,1)+TI1(1)+TI2(1) + TELAS(IB,2)=TELAS(IB,2)+TI1(2)+TI2(2) + TELAS(IB,3)=TELAS(IB,3)+TI1(3)+TI2(3) + TELAS(IB+1,1)=TELAS(IB+1,1)-TI1(1) + TELAS(IB+1,2)=TELAS(IB+1,2)-TI1(2) + TELAS(IB+1,3)=TELAS(IB+1,3)-TI1(3) + + elseif (SIMTYPE.EQ.3) then + + DR(1)=R(IB+1,1)-R(IB,1) + DR(2)=R(IB+1,2)-R(IB,2) + DR(3)=R(IB+1,3)-R(IB,3) + + FELAS(IB,1)=FELAS(IB,1)+EPAR*DR(1) + FELAS(IB,2)=FELAS(IB,2)+EPAR*DR(2) + FELAS(IB,3)=FELAS(IB,3)+EPAR*DR(3) + FELAS(IB+1,1)=FELAS(IB+1,1)-EPAR*DR(1) + FELAS(IB+1,2)=FELAS(IB+1,2)-EPAR*DR(2) + FELAS(IB+1,3)=FELAS(IB+1,3)-EPAR*DR(3) + + TELAS(IB,1)=0. + TELAS(IB,2)=0. + TELAS(IB,3)=0. + TELAS(IB+1,1)=0. + TELAS(IB+1,2)=0. + TELAS(IB+1,3)=0. + + endif + + 40 CONTINUE + 30 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/BDcode/force_ponp.f90 b/BasicWLC/BDcode/force_ponp.f90 new file mode 100644 index 00000000..9ca2379b --- /dev/null +++ b/BasicWLC/BDcode/force_ponp.f90 @@ -0,0 +1,162 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the self-interaction polymer +! using the closest-point interpolation strategy +! +! Andrew Spakowitz +! Written 11-12-13 + + SUBROUTINE force_ponp(FPONP,R,NT,N,NP,LHC,VHC,LBOX,GAM,DT,XIR,SWDT) + + DOUBLE PRECISION R(NT,3) ! Bead positions + INTEGER N,NT,NP ! Current number of beads + DOUBLE PRECISION FPONP(NT,3) ! Self-interaction force + DOUBLE PRECISION FMAG ! Mag of force + DOUBLE PRECISION RIJ ! Interbead dist + DOUBLE PRECISION EIJ(3) ! Interbead unit vector + INTEGER I, J ! Index holders + INTEGER SKIP ! Bead skip index + +! Variables for the calculation + + DOUBLE PRECISION U1(3),U2(3),U1U2 + DOUBLE PRECISION D1,D2 + DOUBLE PRECISION R12(3),D12,E12(3) + DOUBLE PRECISION S1,S2 + DOUBLE PRECISION GI(3) + INTEGER I1,J1,I2,J2 + INTEGER IB1,IB2 + +! Parameters in the simulation + + DOUBLE PRECISION LHC ! HC length + DOUBLE PRECISION SIGP ! HC diameter + DOUBLE PRECISION VHC ! Potential strengths + DOUBLE PRECISION GAM + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION SUM + DOUBLE PRECISION DT + DOUBLE PRECISION XIR + +! Variables for the timestep switch + + INTEGER SWDT + +! Setup the parameters + + IB1=1 + DO 10 I1=1,NP + DO 20 J1=1,N + FPONP(IB1,1)=0. + FPONP(IB1,2)=0. + FPONP(IB1,3)=0. + IB1=IB1+1 + 20 CONTINUE + 10 CONTINUE + +! Calculate the self-interaction forces + + DO 30 I1=1,(NP-1) + DO 40 J1=1,(N-1) + IB1=J1+N*(I1-1) + DO 50 I2=(I1+1),NP + DO 60 J2=1,(N-1) + IB2=J2+N*(I2-1) + R12(1)=R(IB2,1)-R(IB1,1) + R12(2)=R(IB2,2)-R(IB1,2) + R12(3)=R(IB2,3)-R(IB1,3) + R12(1)=R12(1)-nint(R12(1)/LBOX)*LBOX + R12(2)=R12(2)-nint(R12(2)/LBOX)*LBOX + R12(3)=R12(3)-nint(R12(3)/LBOX)*LBOX + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + if (D12.GT.(3.*GAM)) then + goto 70 + endif + + U1(1)=R(IB1+1,1)-R(IB1,1) + U1(2)=R(IB1+1,2)-R(IB1,2) + U1(3)=R(IB1+1,3)-R(IB1,3) + D1=sqrt(U1(1)**2.+U1(2)**2.+U1(3)**2.) + U1(1)=U1(1)/D1 + U1(2)=U1(2)/D1 + U1(3)=U1(3)/D1 + + U2(1)=R(IB2+1,1)-R(IB2,1) + U2(2)=R(IB2+1,2)-R(IB2,2) + U2(3)=R(IB2+1,3)-R(IB2,3) + D2=sqrt(U2(1)**2.+U2(2)**2.+U2(3)**2.) + U2(1)=U2(1)/D2 + U2(2)=U2(2)/D2 + U2(3)=U2(3)/D2 + + U1U2=U1(1)*U2(1)+U1(2)*U2(2)+U1(3)*U2(3) + if (U1U2.EQ.1.) then + goto 70 + endif + + GI(1)=U1(1)-U1U2*U2(1) + GI(2)=U1(2)-U1U2*U2(2) + GI(3)=U1(3)-U1U2*U2(3) + + S1=(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S1.GT.D1.OR.S1.LT.0.) then + goto 70 + endif + + GI(1)=U2(1)-U1U2*U1(1) + GI(2)=U2(2)-U1U2*U1(2) + GI(3)=U2(3)-U1U2*U1(3) + + S2=-(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S2.GT.D2.OR.S2.LT.0.) then + goto 70 + endif + + R12(1)=R12(1)+S2*U2(1)-S1*U1(1) + R12(2)=R12(2)+S2*U2(2)-S1*U1(2) + R12(3)=R12(3)+S2*U2(3)-S1*U1(3) + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + + if (D12.GT.LHC) then + goto 70 + endif + + E12(1)=R12(1)/D12 + E12(2)=R12(2)/D12 + E12(3)=R12(3)/D12 + FMAG=VHC*((LHC/D12)**13.-(LHC/D12)**7.)/LHC + + if ((FMAG/XIR).GT.(0.001/DT)) then + DT=XIR*0.0005/FMAG + SWDT=1 + endif + + FPONP(IB1,1)=FPONP(IB1,1)+FMAG*E12(1)*(-1.+S1/D1) + FPONP(IB1,2)=FPONP(IB1,2)+FMAG*E12(2)*(-1.+S1/D1) + FPONP(IB1,3)=FPONP(IB1,3)+FMAG*E12(3)*(-1.+S1/D1) + FPONP(IB1+1,1)=FPONP(IB1+1,1)+FMAG*E12(1)*(-S1/D1) + FPONP(IB1+1,2)=FPONP(IB1+1,2)+FMAG*E12(2)*(-S1/D1) + FPONP(IB1+1,3)=FPONP(IB1+1,3)+FMAG*E12(3)*(-S1/D1) + FPONP(IB2,1)=FPONP(IB2,1)+FMAG*E12(1)*(1.-S2/D2) + FPONP(IB2,2)=FPONP(IB2,2)+FMAG*E12(2)*(1.-S2/D2) + FPONP(IB2,3)=FPONP(IB2,3)+FMAG*E12(3)*(1.-S2/D2) + FPONP(IB2+1,1)=FPONP(IB2+1,1)+FMAG*E12(1)*(S2/D2) + FPONP(IB2+1,2)=FPONP(IB2+1,2)+FMAG*E12(2)*(S2/D2) + FPONP(IB2+1,3)=FPONP(IB2+1,3)+FMAG*E12(3)*(S2/D2) + + 70 CONTINUE + 60 CONTINUE + 50 CONTINUE + 40 CONTINUE + 30 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* + diff --git a/BasicWLC/BDcode/methyl_profile.f90 b/BasicWLC/BDcode/methyl_profile.f90 new file mode 100644 index 00000000..a18759ee --- /dev/null +++ b/BasicWLC/BDcode/methyl_profile.f90 @@ -0,0 +1,63 @@ +subroutine methyl_profile(nt,meth_status,ktot,km,kd,num_methylated,time,rxn_happen,pairs,dt,dt_mod,nuc_site,num_spread,num_decay) + use mt19937, only : grnd + implicit none + integer, intent(in) :: nt, pairs(2,nt), nuc_site + integer, intent(inout) :: meth_status(nt), rxn_happen, num_spread, num_methylated, num_decay + double precision, intent(in) :: km, kd, ktot, dt, time + double precision, intent(inout) :: dt_mod + double precision :: time_rxn, rn1, rn2, rn3, prob_no_rxn, prob_demeth, prob_meth + integer :: site_rxn, count, i + + ! for pairs of beads that could transfer a methyl mark, + ! perform Gillespie algorithm to determine if reaction happens and then update methyl profile + + if (rxn_happen.eq.1) then + ! does a reaction occur? + rn1 = grnd() + prob_no_rxn = exp(-ktot*dt_mod) + if (rn1.gt.prob_no_rxn) then + ! which reaction occurred? + rn2 = grnd() + prob_demeth = (kd/ktot)*(num_methylated-1) + if (rn2.lt.prob_demeth) then ! one site is demethylated + site_rxn = ceiling(rn2/(kd/ktot)) + count = 0 + i = 1 + do while ((count.lt.site_rxn).and.(i.lt.nuc_site)) + count = count + meth_status(i) + i = i+1 + end do + if ((count.eq.site_rxn).and.((i-1).lt.nuc_site)) then + meth_status(i-1) = 0 + num_decay = num_decay + 1 + elseif ((count.lt.site_rxn).and.(i.eq.nuc_site)) then + i = i+1 + do while (count.lt.site_rxn) + count = count + meth_status(i) + i = i+1 + end do + meth_status(i-1) = 0 + num_decay = num_decay + 1 + end if + else ! one site is methylated + prob_meth = rn2 - prob_demeth + site_rxn = ceiling(prob_meth/(km/ktot)) + meth_status(pairs(2,site_rxn)) = 1 + num_spread = num_spread + 1 + end if + ! at what time did it occur? + rn3 = grnd() + time_rxn = time - (1/ktot)*log(rn2*(prob_no_rxn-1)+1) + dt_mod = time + dt - time_rxn + else + rxn_happen = 0 + end if + end if + + num_methylated = sum(meth_status) + +end + + + + diff --git a/BasicWLC/BDcode/tot_rate_constant.f90 b/BasicWLC/BDcode/tot_rate_constant.f90 new file mode 100644 index 00000000..9a1fb597 --- /dev/null +++ b/BasicWLC/BDcode/tot_rate_constant.f90 @@ -0,0 +1,15 @@ +subroutine tot_rate_constant(nt,could_react,meth_status,km,kd,ktot,num_methylated) + implicit none + integer, intent(in) :: nt, could_react, meth_status(nt) + double precision, intent(in) :: km, kd + double precision, intent(inout) :: ktot + integer, intent(inout) :: num_methylated + + ! determine total rate constant for all possible reactions + ktot = (num_methylated-1)*kd + could_react*km +end + + + + + diff --git a/BasicWLC/DATAcode/MINV.f90 b/BasicWLC/DATAcode/MINV.f90 new file mode 100644 index 00000000..f281242a --- /dev/null +++ b/BasicWLC/DATAcode/MINV.f90 @@ -0,0 +1,49 @@ +!---------------------------------------------------------------* + +! +! This subroutine finds the inverse of a 3x3 matrix and finds +! its determinant +! +! Andrew Spakowitz +! Written 9-1-04 + + SUBROUTINE MINV(A,B,DET) + + DOUBLE PRECISION A(3,3) ! Original matrix + DOUBLE PRECISION B(3,3) ! Inverse matrix + DOUBLE PRECISION DET ! Determinant + DOUBLE PRECISION COA(3,3) ! Cofactor of A + + +! First find the determinant + + DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) + +! Find the Cofactor of A + + COA(1,1) = A(2,2)*A(3,3)-A(2,3)*A(3,2) + COA(1,2) = -(A(2,1)*A(3,3)-A(2,3)*A(3,1)) + COA(1,3) = A(2,1)*A(3,2)-A(2,2)*A(3,1) + COA(2,1) = -(A(1,2)*A(3,3)-A(1,3)*A(3,2)) + COA(2,2) = A(1,1)*A(3,3)-A(1,3)*A(3,1) + COA(2,3) = -(A(1,1)*A(3,2)-A(1,2)*A(3,1)) + COA(3,1) = A(1,2)*A(2,3)-A(1,3)*A(2,2) + COA(3,2) = -(A(1,1)*A(2,3)-A(1,3)*A(2,1)) + COA(3,3) = A(1,1)*A(2,2)-A(1,2)*A(2,1) + +! Find the inverse of A + + B(1,1) = COA(1,1)/DET + B(1,2) = COA(2,1)/DET + B(1,3) = COA(3,1)/DET + B(2,1) = COA(1,2)/DET + B(2,2) = COA(2,2)/DET + B(2,3) = COA(3,2)/DET + B(3,1) = COA(1,3)/DET + B(3,2) = COA(2,3)/DET + B(3,3) = COA(3,3)/DET + + RETURN + END + +!---------------------------------------------------------------* \ No newline at end of file diff --git a/BasicWLC/DATAcode/find_struc.f90 b/BasicWLC/DATAcode/find_struc.f90 new file mode 100644 index 00000000..1ac992e9 --- /dev/null +++ b/BasicWLC/DATAcode/find_struc.f90 @@ -0,0 +1,118 @@ +!---------------------------------------------------------------* + +! +! This subroutine analyses the structure of the expanding +! filament. +! +! Andrew Spakowitz +! Written 9-1-04 + +! Check the calculator of eigenvalue/eigenvector + + SUBROUTINE find_struc(R,NT,N,RCOM,DELR) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(N-1,3) ! Tangent + DOUBLE PRECISION B(N-1) ! Bond length + INTEGER N,NT ! Number of beads + INTEGER I + +! Structure analysis + + DOUBLE PRECISION RCOM(3) ! Center of mass + DOUBLE PRECISION DELR(3) ! Mag of gyration tensor + DOUBLE PRECISION TEMP(3) + DOUBLE PRECISION DELRR(3) ! Real part + DOUBLE PRECISION DELRI(3) ! Imaginary part + DOUBLE PRECISION EVEC(3,3) + DOUBLE PRECISION T(3,3) ! Radius of gyration tensor + double precision fv1(3) + integer iv1(3) + INTEGER ERR + +! Find the center of mass + + RCOM(1)=0. + RCOM(2)=0. + RCOM(3)=0. + DO 10 I=1,N + RCOM(1)=RCOM(1)+R(I,1) + RCOM(2)=RCOM(2)+R(I,2) + RCOM(3)=RCOM(3)+R(I,3) + 10 CONTINUE + RCOM(1)=RCOM(1)/N + RCOM(2)=RCOM(2)/N + RCOM(3)=RCOM(3)/N + +! Find the principle radii of gyration + + T(1,1)=0. + T(1,2)=0. + T(1,3)=0. + T(2,1)=0. + T(2,2)=0. + T(2,3)=0. + T(3,1)=0. + T(3,2)=0. + T(3,3)=0. + DO 20 I=1,N + T(1,1)=T(1,1)+(R(I,1)-RCOM(1))*(R(I,1)-RCOM(1)) + T(1,2)=T(1,2)+(R(I,1)-RCOM(1))*(R(I,2)-RCOM(2)) + T(1,3)=T(1,3)+(R(I,1)-RCOM(1))*(R(I,3)-RCOM(3)) + T(2,1)=T(2,1)+(R(I,2)-RCOM(2))*(R(I,1)-RCOM(1)) + T(2,2)=T(2,2)+(R(I,2)-RCOM(2))*(R(I,2)-RCOM(2)) + T(2,3)=T(2,3)+(R(I,2)-RCOM(2))*(R(I,3)-RCOM(3)) + T(3,1)=T(3,1)+(R(I,3)-RCOM(3))*(R(I,1)-RCOM(1)) + T(3,2)=T(3,2)+(R(I,3)-RCOM(3))*(R(I,2)-RCOM(2)) + T(3,3)=T(3,3)+(R(I,3)-RCOM(3))*(R(I,3)-RCOM(3)) + 20 CONTINUE + T(1,1)=T(1,1)/N + T(1,2)=T(1,2)/N + T(1,3)=T(1,3)/N + T(2,1)=T(2,1)/N + T(2,2)=T(2,2)/N + T(2,3)=T(2,3)/N + T(3,1)=T(3,1)/N + T(3,2)=T(3,2)/N + T(3,3)=T(3,3)/N + +! call rg(3,3,T,DELRR,DELRI,1,EVEC,iv1,fv1,ERR) + + DELR(1)=sqrt(DELRR(1)) + DELR(2)=sqrt(DELRR(2)) + DELR(3)=sqrt(DELRR(3)) + + if (DELR(1).GT.DELR(2).AND.DELR(2).GT.DELR(3)) then + TEMP(1)=DELR(1) + TEMP(2)=DELR(2) + TEMP(3)=DELR(3) + elseif (DELR(2).GT.DELR(1).AND.DELR(1).GT.DELR(3)) then + TEMP(1)=DELR(2) + TEMP(2)=DELR(1) + TEMP(3)=DELR(3) + elseif (DELR(1).GT.DELR(3).AND.DELR(3).GT.DELR(2)) then + TEMP(1)=DELR(1) + TEMP(2)=DELR(3) + TEMP(3)=DELR(2) + elseif (DELR(2).GT.DELR(3).AND.DELR(3).GT.DELR(1)) then + TEMP(1)=DELR(2) + TEMP(2)=DELR(3) + TEMP(3)=DELR(1) + elseif (DELR(3).GT.DELR(1).AND.DELR(1).GT.DELR(2)) then + TEMP(1)=DELR(3) + TEMP(2)=DELR(1) + TEMP(3)=DELR(2) + elseif (DELR(3).GT.DELR(2).AND.DELR(2).GT.DELR(1)) then + TEMP(1)=DELR(3) + TEMP(2)=DELR(2) + TEMP(3)=DELR(1) + endif + + DELR(1)=TEMP(1) + DELR(2)=TEMP(2) + DELR(3)=TEMP(3) + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/MCcode/MC_capsid_ex.f90 b/BasicWLC/MCcode/MC_capsid_ex.f90 new file mode 100644 index 00000000..d7c26983 --- /dev/null +++ b/BasicWLC/MCcode/MC_capsid_ex.f90 @@ -0,0 +1,38 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the change in the energy due to +! interaction with a spherical capsid. +! +! Corrections to force magnitude made 6-3-04. +! +! Andrew Spakowitz +! Written 6-29-04 + + SUBROUTINE MC_ex(DEEX,R,NT,N,DR,I,RAD,VCAP) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION DR(3) ! Change in bead position + DOUBLE PRECISION RMAG,RMAGD ! Dist from origin + INTEGER I ! Current test index + DOUBLE PRECISION RAD ! Radius of capsid + DOUBLE PRECISION VCAP ! Capsid interaction + INTEGER N,NT ! Number of beads + DOUBLE PRECISION DEEX ! Change in external energy + +! Calculate the change in energy + + RMAG=sqrt(R(I,1)**2+R(I,2)**2+R(I,3)**2) + RMAGD=sqrt((R(I,1)+DR(1))**2+(R(I,2)+DR(2))**2+(R(I,3)+DR(3))**2) + if (RMAG.GT.RAD.AND.RMAGD.GT.RAD) then + DEEX=VCAP*((RMAGD-RAD)**4.-(RMAG-RAD)**4.) + elseif (RMAG.GT.RAD.AND.RMAGD.LE.RAD) then + DEEX=-VCAP*((RMAG-RAD)**4.) + elseif (RMAG.LE.RAD.AND.RMAGD.GT.RAD) then + DEEX=VCAP*((RMAGD-RAD)**4.) + endif + + RETURN + END + +!---------------------------------------------------------------* \ No newline at end of file diff --git a/BasicWLC/MCcode/MC_elas.f90 b/BasicWLC/MCcode/MC_elas.f90 new file mode 100644 index 00000000..a0097e3a --- /dev/null +++ b/BasicWLC/MCcode/MC_elas.f90 @@ -0,0 +1,214 @@ +!---------------------------------------------------------------* + +! subroutine MC_eelas +! +! Calculate the change in the polymer elastic energy +! due to the displacement from a MC move + + SUBROUTINE MC_eelas(DEELAS,R,U,RP,UP,NT,N,NP,IP, & + IB1,IB2,IT1,IT2,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION RP(NT,3) ! Bead positions + DOUBLE PRECISION UP(NT,3) ! Tangent vectors + INTEGER N,NP,NT ! Number of beads + + INTEGER IP ! Test polymer + INTEGER IB1 ! Test bead position 1 + INTEGER IT1 ! Index of test bead 1 + INTEGER IB2 ! Test bead position 2 + INTEGER IT2 ! Index of test bead 2 + + DOUBLE PRECISION DEELAS ! Change in ECOM + +! Polymer properties + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Variables for force and torque calculations + + DOUBLE PRECISION DR(3),DRPAR,DRPERP(3),DRPERPM(3) + DOUBLE PRECISION FI(3),TI(3) + DOUBLE PRECISION U1U2,GI(3),DOTGU,HI(3) + DOUBLE PRECISION UNORM + +! Setup parameters + + DEELAS=0. + +! Calculate the change in the energy + + if (IB1.NE.1) then + + if (SIMTYPE.EQ.1.AND.IB1.NE.N) then + + U(IT1-1,1)=R(IT1,1)-R(IT1-1,1) + U(IT1-1,2)=R(IT1,2)-R(IT1-1,2) + U(IT1-1,3)=R(IT1,3)-R(IT1-1,3) + UNORM=sqrt(U(IT1-1,1)**2.+U(IT1-1,2)**2.+U(IT1-1,3)**2.) + U(IT1-1,1)=U(IT1-1,1)/UNORM + U(IT1-1,2)=U(IT1-1,2)/UNORM + U(IT1-1,3)=U(IT1-1,3)/UNORM + + U(IT1,1)=R(IT1+1,1)-R(IT1,1) + U(IT1,2)=R(IT1+1,2)-R(IT1,2) + U(IT1,3)=R(IT1+1,3)-R(IT1,3) + UNORM=sqrt(U(IT1,1)**2.+U(IT1,2)**2.+U(IT1,3)**2.) + U(IT1,1)=U(IT1,1)/UNORM + U(IT1,2)=U(IT1,2)/UNORM + U(IT1,3)=U(IT1,3)/UNORM + + UP(IT1,1)=RP(IT1+1,1)-RP(IT1,1) + UP(IT1,2)=RP(IT1+1,2)-RP(IT1,2) + UP(IT1,3)=RP(IT1+1,3)-RP(IT1,3) + UNORM=sqrt(UP(IT1,1)**2.+UP(IT1,2)**2.+UP(IT1,3)**2.) + UP(IT1,1)=UP(IT1,1)/UNORM + UP(IT1,2)=UP(IT1,2)/UNORM + UP(IT1,3)=UP(IT1,3)/UNORM + + U1U2=U(IT1-1,1)*U(IT1,1)+U(IT1-1,2)*U(IT1,2)+U(IT1-1,3)*U(IT1,3) + DEELAS=DEELAS+EB*U1U2 + U1U2=U(IT1-1,1)*UP(IT1,1)+U(IT1-1,2)*UP(IT1,2)+U(IT1-1,3)*UP(IT1,3) + DEELAS=DEELAS-EB*U1U2 + + elseif (SIMTYPE.EQ.2) then + + DR(1)=R(IT1,1)-R(IT1-1,1) + DR(2)=R(IT1,2)-R(IT1-1,2) + DR(3)=R(IT1,3)-R(IT1-1,3) + DRPAR=DR(1)*U(IT1-1,1)+DR(2)*U(IT1-1,2)+DR(3)*U(IT1-1,3) + + DRPERP(1)=DR(1)-DRPAR*U(IT1-1,1) + DRPERP(2)=DR(2)-DRPAR*U(IT1-1,2) + DRPERP(3)=DR(3)-DRPAR*U(IT1-1,3) + U1U2=U(IT1-1,1)*U(IT1,1)+U(IT1-1,2)*U(IT1,2)+U(IT1-1,3)*U(IT1,3) + + GI(1)=(U(IT1,1)-U(IT1-1,1)-ETA*DRPERP(1)) + GI(2)=(U(IT1,2)-U(IT1-1,2)-ETA*DRPERP(2)) + GI(3)=(U(IT1,3)-U(IT1-1,3)-ETA*DRPERP(3)) + + DEELAS=DEELAS-0.5*EB*(GI(1)**2.+GI(2)**2.+GI(3)**2.) & + -0.5*EPAR*(DRPAR-GAM)**2.-0.5*EPERP*(DRPERP(1)**2.+DRPERP(2)**2.+DRPERP(3)**2.) + + DR(1)=RP(IT1,1)-R(IT1-1,1) + DR(2)=RP(IT1,2)-R(IT1-1,2) + DR(3)=RP(IT1,3)-R(IT1-1,3) + DRPAR=DR(1)*U(IT1-1,1)+DR(2)*U(IT1-1,2)+DR(3)*U(IT1-1,3) + + DRPERP(1)=DR(1)-DRPAR*U(IT1-1,1) + DRPERP(2)=DR(2)-DRPAR*U(IT1-1,2) + DRPERP(3)=DR(3)-DRPAR*U(IT1-1,3) + U1U2=U(IT1-1,1)*UP(IT1,1)+U(IT1-1,2)*UP(IT1,2)+U(IT1-1,3)*UP(IT1,3) + + GI(1)=(UP(IT1,1)-U(IT1-1,1)-ETA*DRPERP(1)) + GI(2)=(UP(IT1,2)-U(IT1-1,2)-ETA*DRPERP(2)) + GI(3)=(UP(IT1,3)-U(IT1-1,3)-ETA*DRPERP(3)) + + DEELAS=DEELAS+0.5*EB*(GI(1)**2.+GI(2)**2.+GI(3)**2.) & + +0.5*EPAR*(DRPAR-GAM)**2.+0.5*EPERP*(DRPERP(1)**2.+DRPERP(2)**2.+DRPERP(3)**2.) + + elseif (SIMTYPE.EQ.3) then + + DR(1)=R(IT1,1)-R(IT1-1,1) + DR(2)=R(IT1,2)-R(IT1-1,2) + DR(3)=R(IT1,3)-R(IT1-1,3) + DEELAS=DEELAS-0.5*EPAR*(DR(1)**2.+DR(2)**2.+DR(3)**2.) + DR(1)=RP(IT1,1)-R(IT1-1,1) + DR(2)=RP(IT1,2)-R(IT1-1,2) + DR(3)=RP(IT1,3)-R(IT1-1,3) + DEELAS=DEELAS+0.5*EPAR*(DR(1)**2.+DR(2)**2.+DR(3)**2.) + + endif + endif + + if (IB2.NE.N) then + + if (SIMTYPE.EQ.1.AND.IB2.NE.1) then + + U(IT2-1,1)=R(IT2,1)-R(IT2-1,1) + U(IT2-1,2)=R(IT2,2)-R(IT2-1,2) + U(IT2-1,3)=R(IT2,3)-R(IT2-1,3) + UNORM=sqrt(U(IT2-1,1)**2.+U(IT2-1,2)**2.+U(IT2-1,3)**2.) + U(IT2-1,1)=U(IT2-1,1)/UNORM + U(IT2-1,2)=U(IT2-1,2)/UNORM + U(IT2-1,3)=U(IT2-1,3)/UNORM + + U(IT2,1)=R(IT2+1,1)-R(IT2,1) + U(IT2,2)=R(IT2+1,2)-R(IT2,2) + U(IT2,3)=R(IT2+1,3)-R(IT2,3) + UNORM=sqrt(U(IT2,1)**2.+U(IT2,2)**2.+U(IT2,3)**2.) + U(IT2,1)=U(IT2,1)/UNORM + U(IT2,2)=U(IT2,2)/UNORM + U(IT2,3)=U(IT2,3)/UNORM + + UP(IT2-1,1)=RP(IT2,1)-RP(IT2-1,1) + UP(IT2-1,2)=RP(IT2,2)-RP(IT2-1,2) + UP(IT2-1,3)=RP(IT2,3)-RP(IT2-1,3) + UNORM=sqrt(UP(IT2-1,1)**2.+UP(IT2-1,2)**2.+UP(IT2-1,3)**2.) + UP(IT2-1,1)=UP(IT2-1,1)/UNORM + UP(IT2-1,2)=UP(IT2-1,2)/UNORM + UP(IT2-1,3)=UP(IT2-1,3)/UNORM + + U1U2=U(IT2-1,1)*U(IT2,1)+U(IT2-1,2)*U(IT2,2)+U(IT2-1,3)*U(IT2,3) + DEELAS=DEELAS+EB*U1U2 + U1U2=UP(IT2-1,1)*U(IT2,1)+UP(IT2-1,2)*U(IT2,2)+UP(IT2-1,3)*U(IT2,3) + DEELAS=DEELAS-EB*U1U2 + + elseif (SIMTYPE.EQ.2) then + + DR(1)=R(IT2+1,1)-R(IT2,1) + DR(2)=R(IT2+1,2)-R(IT2,2) + DR(3)=R(IT2+1,3)-R(IT2,3) + DRPAR=DR(1)*U(IT2,1)+DR(2)*U(IT2,2)+DR(3)*U(IT2,3) + + DRPERP(1)=DR(1)-DRPAR*U(IT2,1) + DRPERP(2)=DR(2)-DRPAR*U(IT2,2) + DRPERP(3)=DR(3)-DRPAR*U(IT2,3) + U1U2=U(IT2,1)*U(IT2+1,1)+U(IT2,2)*U(IT2+1,2)+U(IT2,3)*U(IT2+1,3) + + GI(1)=(U(IT2+1,1)-U(IT2,1)-ETA*DRPERP(1)) + GI(2)=(U(IT2+1,2)-U(IT2,2)-ETA*DRPERP(2)) + GI(3)=(U(IT2+1,3)-U(IT2,3)-ETA*DRPERP(3)) + + DEELAS=DEELAS-0.5*EB*(GI(1)**2.+GI(2)**2.+GI(3)**2.) & + -0.5*EPAR*(DRPAR-GAM)**2.-0.5*EPERP*(DRPERP(1)**2.+DRPERP(2)**2.+DRPERP(3)**2.) + + DR(1)=R(IT2+1,1)-RP(IT2,1) + DR(2)=R(IT2+1,2)-RP(IT2,2) + DR(3)=R(IT2+1,3)-RP(IT2,3) + DRPAR=DR(1)*UP(IT2,1)+DR(2)*UP(IT2,2)+DR(3)*UP(IT2,3) + + DRPERP(1)=DR(1)-DRPAR*UP(IT2,1) + DRPERP(2)=DR(2)-DRPAR*UP(IT2,2) + DRPERP(3)=DR(3)-DRPAR*UP(IT2,3) + U1U2=UP(IT2,1)*U(IT2+1,1)+UP(IT2,2)*U(IT2+1,2)+UP(IT2,3)*U(IT2+1,3) + + GI(1)=(U(IT2+1,1)-UP(IT2,1)-ETA*DRPERP(1)) + GI(2)=(U(IT2+1,2)-UP(IT2,2)-ETA*DRPERP(2)) + GI(3)=(U(IT2+1,3)-UP(IT2,3)-ETA*DRPERP(3)) + + DEELAS=DEELAS+0.5*EB*(GI(1)**2.+GI(2)**2.+GI(3)**2.) & + +0.5*EPAR*(DRPAR-GAM)**2.+0.5*EPERP*(DRPERP(1)**2.+DRPERP(2)**2.+DRPERP(3)**2.) + + elseif (SIMTYPE.EQ.3) then + + DR(1)=R(IT2+1,1)-R(IT2,1) + DR(2)=R(IT2+1,2)-R(IT2,2) + DR(3)=R(IT2+1,3)-R(IT2,3) + DEELAS=DEELAS-0.5*EPAR*(DR(1)**2.+DR(2)**2.+DR(3)**2.) + DR(1)=R(IT2+1,1)-RP(IT2,1) + DR(2)=R(IT2+1,2)-RP(IT2,2) + DR(3)=R(IT2+1,3)-RP(IT2,3) + DEELAS=DEELAS+0.5*EPAR*(DR(1)**2.+DR(2)**2.+DR(3)**2.) + + endif + + endif + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/MCcode/MC_move.f90 b/BasicWLC/MCcode/MC_move.f90 new file mode 100644 index 00000000..bb2369ef --- /dev/null +++ b/BasicWLC/MCcode/MC_move.f90 @@ -0,0 +1,326 @@ +!---------------------------------------------------------------* + +! subroutine MC_move +! +! Subroutine to perform conformational moves for MC simulation +! Move type include: +! 1. Crank-shaft move (internal segment) +! 2. Translational slide (internal segment) +! 3. End pivot move (end segment) +! 4. Tangent rotation (single tangent) +! 5. Whole chain rotation (whole chain) +! 6. Whole chain translation (whole chain) +! + + SUBROUTINE MC_move(R,U,RP,UP,NT,N,NP,IP,IB1,IB2, & + IT1,IT2,IDUM,MCTYPE,MCAMP) + + use mt19937, only : grnd + + PARAMETER (PI=3.141592654) ! Value of pi + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION RP(NT,3) ! Bead positions + DOUBLE PRECISION UP(NT,3) ! Tangent vectors + INTEGER N,NP,NT ! Number of beads + + INTEGER IP ! Test polymer + INTEGER IB1 ! Test bead position 1 + INTEGER IT1 ! Index of test bead 1 + INTEGER IB2 ! Test bead position 2 + INTEGER IT2 ! Index of test bead 2 + + INTEGER I,J ! Test indices + +! Variables for the crank-shaft move + + DOUBLE PRECISION TA(3) ! Axis of rotation + DOUBLE PRECISION P1(3) ! Point on rotation line + DOUBLE PRECISION MAG ! Magnitude of vector + DOUBLE PRECISION ROT(4,4) ! Rotation matrix + + INTEGER IDUM ! Seed for the generator + DOUBLE PRECISION ALPHA ! Angle of move + DOUBLE PRECISION BETA ! Angle of move + +! MC adaptation variables + + DOUBLE PRECISION MCAMP(6) ! Amplitude of random change + INTEGER MCTYPE ! Type of MC move + DOUBLE PRECISION DR(3) ! Displacement for slide move + INTEGER TEMP + +! Perform crank-shaft move (MCTYPE 1) + + if (MCTYPE.EQ.1) then + IP=nint(0.5+grnd()*NP) + IB1=nint(0.5+grnd()*N) + IB2=nint(0.5+grnd()*N) + if (IB2.LT.IB1) then + TEMP=IB1 + IB1=IB2 + IB2=TEMP + endif + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + + if (IB1.EQ.IB2.AND.IB1.EQ.1) then + TA(1)=R(IT1+1,1)-R(IT1,1) + TA(2)=R(IT1+1,2)-R(IT1,2) + TA(3)=R(IT1+1,3)-R(IT1,3) + elseif (IB1.EQ.IB2.AND.IB1.EQ.N) then + TA(1)=R(IT1,1)-R(IT1-1,1) + TA(2)=R(IT1,2)-R(IT1-1,2) + TA(3)=R(IT1,3)-R(IT1-1,3) + elseif (IB1.EQ.IB2.AND.IB1.NE.1.AND.IB2.NE.N) then + TA(1)=R(IT1+1,1)-R(IT1-1,1) + TA(2)=R(IT1+1,2)-R(IT1-1,2) + TA(3)=R(IT1+1,3)-R(IT1-1,3) + else + TA(1)=R(IT2,1)-R(IT1,1) + TA(2)=R(IT2,2)-R(IT1,2) + TA(3)=R(IT2,3)-R(IT1,3) + endif + MAG=sqrt(TA(1)**2.+TA(2)**2.+TA(3)**2.) + TA(1)=TA(1)/MAG + TA(2)=TA(2)/MAG + TA(3)=TA(3)/MAG + P1(1)=R(IT1,1) + P1(2)=R(IT1,2) + P1(3)=R(IT1,3) + + ALPHA=MCAMP(1)*(grnd()-0.5) + + ROT(1,1)=TA(1)**2.+(TA(2)**2.+TA(3)**2.)*cos(ALPHA) + ROT(1,2)=TA(1)*TA(2)*(1.-cos(ALPHA))-TA(3)*sin(ALPHA) + ROT(1,3)=TA(1)*TA(3)*(1.-cos(ALPHA))+TA(2)*sin(ALPHA) + ROT(1,4)=(P1(1)*(1.-TA(1)**2.) & + -TA(1)*(P1(2)*TA(2)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(2)*TA(3)-P1(3)*TA(2))*sin(ALPHA) + + ROT(2,1)=TA(1)*TA(2)*(1.-cos(ALPHA))+TA(3)*sin(ALPHA) + ROT(2,2)=TA(2)**2.+(TA(1)**2.+TA(3)**2.)*cos(ALPHA) + ROT(2,3)=TA(2)*TA(3)*(1.-cos(ALPHA))-TA(1)*sin(ALPHA) + ROT(2,4)=(P1(2)*(1.-TA(2)**2.) & + -TA(2)*(P1(1)*TA(1)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(3)*TA(1)-P1(1)*TA(3))*sin(ALPHA) + + ROT(3,1)=TA(1)*TA(3)*(1.-cos(ALPHA))-TA(2)*sin(ALPHA) + ROT(3,2)=TA(2)*TA(3)*(1.-cos(ALPHA))+TA(1)*sin(ALPHA) + ROT(3,3)=TA(3)**2.+(TA(1)**2.+TA(2)**2.)*cos(ALPHA) + ROT(3,4)=(P1(3)*(1.-TA(3)**2.) & + -TA(3)*(P1(1)*TA(1)+P1(2)*TA(2)))*(1.-cos(ALPHA))+(P1(1)*TA(2)-P1(2)*TA(1))*sin(ALPHA) + + DO 10 I=IT1,IT2 + RP(I,1)=ROT(1,4)+ROT(1,1)*R(I,1)+ROT(1,2)*R(I,2)+ROT(1,3)*R(I,3) + RP(I,2)=ROT(2,4)+ROT(2,1)*R(I,1)+ROT(2,2)*R(I,2)+ROT(2,3)*R(I,3) + RP(I,3)=ROT(3,4)+ROT(3,1)*R(I,1)+ROT(3,2)*R(I,2)+ROT(3,3)*R(I,3) + UP(I,1)=ROT(1,1)*U(I,1)+ROT(1,2)*U(I,2)+ROT(1,3)*U(I,3) + UP(I,2)=ROT(2,1)*U(I,1)+ROT(2,2)*U(I,2)+ROT(2,3)*U(I,3) + UP(I,3)=ROT(3,1)*U(I,1)+ROT(3,2)*U(I,2)+ROT(3,3)*U(I,3) + 10 CONTINUE + +! Perform slide move (MCTYPE 2) + + elseif (MCTYPE.EQ.2) then + + IP=nint(0.5+grnd()*NP) + IB1=nint(1.5+grnd()*(N-2.)) + IB2=nint(1.5+grnd()*(N-2.)) + if (IB2.LT.IB1) then + TEMP=IB1 + IB1=IB2 + IB2=TEMP + endif + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + + DR(1)=MCAMP(2)*(grnd()-0.5) + DR(2)=MCAMP(2)*(grnd()-0.5) + DR(3)=MCAMP(2)*(grnd()-0.5) + + DO 20 I=IT1,IT2 + RP(I,1)=R(I,1)+DR(1) + RP(I,2)=R(I,2)+DR(2) + RP(I,3)=R(I,3)+DR(3) + UP(I,1)=U(I,1) + UP(I,2)=U(I,2) + UP(I,3)=U(I,3) + 20 CONTINUE + +! Perform pivot move (MCTYPE 3) + + elseif (MCTYPE.EQ.3) then + + IP=nint(0.5+grnd()*NP) + IB1=nint(0.5+grnd()*N) + if (IB1.LT.(N/2.)) then + IB2=IB1 + IB1=1 + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + P1(1)=R(IT2,1) + P1(2)=R(IT2,2) + P1(3)=R(IT2,3) + else + IB2=N + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + P1(1)=R(IT1,1) + P1(2)=R(IT1,2) + P1(3)=R(IT1,3) + endif + + ALPHA=2.*PI*grnd() + BETA=acos(2.*grnd()-1.) + TA(1)=sin(BETA)*cos(ALPHA) + TA(2)=sin(BETA)*sin(ALPHA) + TA(3)=cos(BETA) + + ALPHA=MCAMP(3)*(grnd()-0.5) + + ROT(1,1)=TA(1)**2.+(TA(2)**2.+TA(3)**2.)*cos(ALPHA) + ROT(1,2)=TA(1)*TA(2)*(1.-cos(ALPHA))-TA(3)*sin(ALPHA) + ROT(1,3)=TA(1)*TA(3)*(1.-cos(ALPHA))+TA(2)*sin(ALPHA) + ROT(1,4)=(P1(1)*(1.-TA(1)**2.) & + -TA(1)*(P1(2)*TA(2)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(2)*TA(3)-P1(3)*TA(2))*sin(ALPHA) + + ROT(2,1)=TA(1)*TA(2)*(1.-cos(ALPHA))+TA(3)*sin(ALPHA) + ROT(2,2)=TA(2)**2.+(TA(1)**2.+TA(3)**2.)*cos(ALPHA) + ROT(2,3)=TA(2)*TA(3)*(1.-cos(ALPHA))-TA(1)*sin(ALPHA) + ROT(2,4)=(P1(2)*(1.-TA(2)**2.) & + -TA(2)*(P1(1)*TA(1)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(3)*TA(1)-P1(1)*TA(3))*sin(ALPHA) + + ROT(3,1)=TA(1)*TA(3)*(1.-cos(ALPHA))-TA(2)*sin(ALPHA) + ROT(3,2)=TA(2)*TA(3)*(1.-cos(ALPHA))+TA(1)*sin(ALPHA) + ROT(3,3)=TA(3)**2.+(TA(1)**2.+TA(2)**2.)*cos(ALPHA) + ROT(3,4)=(P1(3)*(1.-TA(3)**2.) & + -TA(3)*(P1(1)*TA(1)+P1(2)*TA(2)))*(1.-cos(ALPHA))+(P1(1)*TA(2)-P1(2)*TA(1))*sin(ALPHA) + + DO 30 I=IT1,IT2 + RP(I,1)=ROT(1,4)+ROT(1,1)*R(I,1)+ROT(1,2)*R(I,2)+ROT(1,3)*R(I,3) + RP(I,2)=ROT(2,4)+ROT(2,1)*R(I,1)+ROT(2,2)*R(I,2)+ROT(2,3)*R(I,3) + RP(I,3)=ROT(3,4)+ROT(3,1)*R(I,1)+ROT(3,2)*R(I,2)+ROT(3,3)*R(I,3) + UP(I,1)=ROT(1,1)*U(I,1)+ROT(1,2)*U(I,2)+ROT(1,3)*U(I,3) + UP(I,2)=ROT(2,1)*U(I,1)+ROT(2,2)*U(I,2)+ROT(2,3)*U(I,3) + UP(I,3)=ROT(3,1)*U(I,1)+ROT(3,2)*U(I,2)+ROT(3,3)*U(I,3) + 30 CONTINUE + +! Perform rotate move (MCTYPE 4) + + elseif (MCTYPE.EQ.4) then + + IP=nint(0.5+grnd()*NP) + IB1=nint(0.5+grnd()*N) + IB2=IB1 + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + + ALPHA=2.*PI*grnd() + BETA=acos(2.*grnd()-1.) + TA(1)=sin(BETA)*cos(ALPHA) + TA(2)=sin(BETA)*sin(ALPHA) + TA(3)=cos(BETA) + + ALPHA=MCAMP(4)*(grnd()-0.5) + + ROT(1,1)=TA(1)**2.+(TA(2)**2.+TA(3)**2.)*cos(ALPHA) + ROT(1,2)=TA(1)*TA(2)*(1.-cos(ALPHA))-TA(3)*sin(ALPHA) + ROT(1,3)=TA(1)*TA(3)*(1.-cos(ALPHA))+TA(2)*sin(ALPHA) + + ROT(2,1)=TA(1)*TA(2)*(1.-cos(ALPHA))+TA(3)*sin(ALPHA) + ROT(2,2)=TA(2)**2.+(TA(1)**2.+TA(3)**2.)*cos(ALPHA) + ROT(2,3)=TA(2)*TA(3)*(1.-cos(ALPHA))-TA(1)*sin(ALPHA) + + ROT(3,1)=TA(1)*TA(3)*(1.-cos(ALPHA))-TA(2)*sin(ALPHA) + ROT(3,2)=TA(2)*TA(3)*(1.-cos(ALPHA))+TA(1)*sin(ALPHA) + ROT(3,3)=TA(3)**2.+(TA(1)**2.+TA(2)**2.)*cos(ALPHA) + + I=IT1 + UP(I,1)=ROT(1,1)*U(I,1)+ROT(1,2)*U(I,2)+ROT(1,3)*U(I,3) + UP(I,2)=ROT(2,1)*U(I,1)+ROT(2,2)*U(I,2)+ROT(2,3)*U(I,3) + UP(I,3)=ROT(3,1)*U(I,1)+ROT(3,2)*U(I,2)+ROT(3,3)*U(I,3) + + RP(I,1)=R(I,1) + RP(I,2)=R(I,2) + RP(I,3)=R(I,3) + +! Perform a full chain rotation + + elseif (MCTYPE.EQ.5) then + + IP=nint(0.5+grnd()*NP) + IB1=1 + IB2=N + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + + ALPHA=2.*PI*grnd() + BETA=acos(2.*grnd()-1.) + TA(1)=sin(BETA)*cos(ALPHA) + TA(2)=sin(BETA)*sin(ALPHA) + TA(3)=cos(BETA) + + ! use ~central bead to put axes through + ! you could also use center of mass if you wanted + P1(1)=R((IT2+IT1)/2,1) + P1(2)=R((IT2+IT1)/2,2) + P1(3)=R((IT2+IT1)/2,3) + + ALPHA=MCAMP(5)*(grnd()-0.5) + + ROT(1,1)=TA(1)**2.+(TA(2)**2.+TA(3)**2.)*cos(ALPHA) + ROT(1,2)=TA(1)*TA(2)*(1.-cos(ALPHA))-TA(3)*sin(ALPHA) + ROT(1,3)=TA(1)*TA(3)*(1.-cos(ALPHA))+TA(2)*sin(ALPHA) + ROT(1,4)=(P1(1)*(1.-TA(1)**2.) & + -TA(1)*(P1(2)*TA(2)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(2)*TA(3)-P1(3)*TA(2))*sin(ALPHA) + + ROT(2,1)=TA(1)*TA(2)*(1.-cos(ALPHA))+TA(3)*sin(ALPHA) + ROT(2,2)=TA(2)**2.+(TA(1)**2.+TA(3)**2.)*cos(ALPHA) + ROT(2,3)=TA(2)*TA(3)*(1.-cos(ALPHA))-TA(1)*sin(ALPHA) + ROT(2,4)=(P1(2)*(1.-TA(2)**2.) & + -TA(2)*(P1(1)*TA(1)+P1(3)*TA(3)))*(1.-cos(ALPHA))+(P1(3)*TA(1)-P1(1)*TA(3))*sin(ALPHA) + + ROT(3,1)=TA(1)*TA(3)*(1.-cos(ALPHA))-TA(2)*sin(ALPHA) + ROT(3,2)=TA(2)*TA(3)*(1.-cos(ALPHA))+TA(1)*sin(ALPHA) + ROT(3,3)=TA(3)**2.+(TA(1)**2.+TA(2)**2.)*cos(ALPHA) + ROT(3,4)=(P1(3)*(1.-TA(3)**2.) & + -TA(3)*(P1(1)*TA(1)+P1(2)*TA(2)))*(1.-cos(ALPHA))+(P1(1)*TA(2)-P1(2)*TA(1))*sin(ALPHA) + + DO 40 I=IT1,IT2 + RP(I,1)=ROT(1,4)+ROT(1,1)*R(I,1)+ROT(1,2)*R(I,2)+ROT(1,3)*R(I,3) + RP(I,2)=ROT(2,4)+ROT(2,1)*R(I,1)+ROT(2,2)*R(I,2)+ROT(2,3)*R(I,3) + RP(I,3)=ROT(3,4)+ROT(3,1)*R(I,1)+ROT(3,2)*R(I,2)+ROT(3,3)*R(I,3) + UP(I,1)=ROT(1,1)*U(I,1)+ROT(1,2)*U(I,2)+ROT(1,3)*U(I,3) + UP(I,2)=ROT(2,1)*U(I,1)+ROT(2,2)*U(I,2)+ROT(2,3)*U(I,3) + UP(I,3)=ROT(3,1)*U(I,1)+ROT(3,2)*U(I,2)+ROT(3,3)*U(I,3) + 40 CONTINUE + +! Perform full chain slide move (MCTYPE 6) + + elseif (MCTYPE.EQ.6) then + + IP=nint(0.5+grnd()*NP) + IB1=1 + IB2=N + IT1=N*(IP-1)+IB1 + IT2=N*(IP-1)+IB2 + + DR(1)=MCAMP(6)*(grnd()-0.5) + DR(2)=MCAMP(6)*(grnd()-0.5) + DR(3)=MCAMP(6)*(grnd()-0.5) + + DO 50 I=IT1,IT2 + RP(I,1)=R(I,1)+DR(1) + RP(I,2)=R(I,2)+DR(2) + RP(I,3)=R(I,3)+DR(3) + UP(I,1)=U(I,1) + UP(I,2)=U(I,2) + UP(I,3)=U(I,3) + 50 CONTINUE + + endif + + RETURN + END + +!---------------------------------------------------------------! diff --git a/BasicWLC/MCcode/MC_self.f90 b/BasicWLC/MCcode/MC_self.f90 new file mode 100644 index 00000000..f61cce03 --- /dev/null +++ b/BasicWLC/MCcode/MC_self.f90 @@ -0,0 +1,226 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the change in the self energy for +! a small Monte Carlo move in the position. +! +! Corrections to force magnitude made 6-3-04. +! +! Andrew Spakowitz +! Written 6-29-04 + + SUBROUTINE MC_self(DESELF,R,U,RP,UP,NT,N,NP,IP,IB1,IB2,IT1,IT2,LHC,VHC,LBOX,GAM) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION RP(NT,3) ! Bead positions + DOUBLE PRECISION UP(NT,3) ! Tangent vectors + INTEGER N,NP,NT ! Number of beads + +! Variables for the calculation + + DOUBLE PRECISION U1(3),U2(3),U1U2 + DOUBLE PRECISION D1,D2 + DOUBLE PRECISION R12(3),D12,E12(3) + DOUBLE PRECISION S1,S2 + DOUBLE PRECISION GI(3) + INTEGER I1,J1,I2,J2 + INTEGER IMIN,IMAX + INTEGER IB1,IB2 + INTEGER IND1,IND2 + + INTEGER I ! Current test index + INTEGER J ! Index holder + INTEGER SKIP ! Bead skip index + DOUBLE PRECISION DESELF + DOUBLE PRECISION EMAG + +! Parameters in the simulation + + DOUBLE PRECISION LHC ! HC length + DOUBLE PRECISION SIGP ! HC diameter + DOUBLE PRECISION VHC ! Potential strengths + DOUBLE PRECISION GAM + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION SUM + DOUBLE PRECISION DT + DOUBLE PRECISION XIR + +! Calculate the self-interaction forces + + DESELF=0. + if (IB1.EQ.1) then + IMIN=1 + else + IMIN=IB1-1 + endif + if (IB2.EQ.N) then + IMAX=(N-1) + else + IMAX=IB2 + endif + + DO 30 I1=1,NP + if (I1.EQ.IP) then + goto 100 + endif + + DO 40 J1=1,(N-1) + IND1=J1+N*(I1-1) + I2=IP + + DO 50 J2=IMIN,IMAX + IND2=J2+N*(I2-1) + R12(1)=R(IND2,1)-R(IND1,1) + R12(2)=R(IND2,2)-R(IND1,2) + R12(3)=R(IND2,3)-R(IND1,3) + R12(1)=R12(1)-nint(R12(1)/LBOX)*LBOX + R12(2)=R12(2)-nint(R12(2)/LBOX)*LBOX + R12(3)=R12(3)-nint(R12(3)/LBOX)*LBOX + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + if (D12.GT.(3.*GAM)) then + goto 70 + endif + + U1(1)=R(IND1+1,1)-R(IND1,1) + U1(2)=R(IND1+1,2)-R(IND1,2) + U1(3)=R(IND1+1,3)-R(IND1,3) + D1=sqrt(U1(1)**2.+U1(2)**2.+U1(3)**2.) + U1(1)=U1(1)/D1 + U1(2)=U1(2)/D1 + U1(3)=U1(3)/D1 + + U2(1)=R(IND2+1,1)-R(IND2,1) + U2(2)=R(IND2+1,2)-R(IND2,2) + U2(3)=R(IND2+1,3)-R(IND2,3) + D2=sqrt(U2(1)**2.+U2(2)**2.+U2(3)**2.) + U2(1)=U2(1)/D2 + U2(2)=U2(2)/D2 + U2(3)=U2(3)/D2 + + U1U2=U1(1)*U2(1)+U1(2)*U2(2)+U1(3)*U2(3) + if (U1U2.EQ.1.) then + goto 70 + endif + + GI(1)=U1(1)-U1U2*U2(1) + GI(2)=U1(2)-U1U2*U2(2) + GI(3)=U1(3)-U1U2*U2(3) + + S1=(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S1.GT.D1.OR.S1.LT.0.) then + goto 70 + endif + + GI(1)=U2(1)-U1U2*U1(1) + GI(2)=U2(2)-U1U2*U1(2) + GI(3)=U2(3)-U1U2*U1(3) + + S2=-(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S2.GT.D2.OR.S2.LT.0.) then + goto 70 + endif + + R12(1)=R12(1)+S2*U2(1)-S1*U1(1) + R12(2)=R12(2)+S2*U2(2)-S1*U1(2) + R12(3)=R12(3)+S2*U2(3)-S1*U1(3) + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + + if (D12.GT.LHC) then + goto 70 + endif + + EMAG=VHC*((LHC/D12)**12.-2.*(LHC/D12)**6.+1.)/12. + + DESELF=DESELF-EMAG + + 70 CONTINUE + + 50 CONTINUE + + DO 80 J2=IMIN,IMAX + IND2=J2+N*(I2-1) + R12(1)=RP(IND2,1)-R(IND1,1) + R12(2)=RP(IND2,2)-R(IND1,2) + R12(3)=RP(IND2,3)-R(IND1,3) + R12(1)=R12(1)-nint(R12(1)/LBOX)*LBOX + R12(2)=R12(2)-nint(R12(2)/LBOX)*LBOX + R12(3)=R12(3)-nint(R12(3)/LBOX)*LBOX + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + if (D12.GT.(3.*GAM)) then + goto 90 + endif + + U1(1)=R(IND1+1,1)-R(IND1,1) + U1(2)=R(IND1+1,2)-R(IND1,2) + U1(3)=R(IND1+1,3)-R(IND1,3) + D1=sqrt(U1(1)**2.+U1(2)**2.+U1(3)**2.) + U1(1)=U1(1)/D1 + U1(2)=U1(2)/D1 + U1(3)=U1(3)/D1 + + U2(1)=RP(IND2+1,1)-RP(IND2,1) + U2(2)=RP(IND2+1,2)-RP(IND2,2) + U2(3)=RP(IND2+1,3)-RP(IND2,3) + D2=sqrt(U2(1)**2.+U2(2)**2.+U2(3)**2.) + U2(1)=U2(1)/D2 + U2(2)=U2(2)/D2 + U2(3)=U2(3)/D2 + + U1U2=U1(1)*U2(1)+U1(2)*U2(2)+U1(3)*U2(3) + if (U1U2.EQ.1.) then + goto 90 + endif + + GI(1)=U1(1)-U1U2*U2(1) + GI(2)=U1(2)-U1U2*U2(2) + GI(3)=U1(3)-U1U2*U2(3) + + S1=(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S1.GT.D1.OR.S1.LT.0.) then + goto 90 + endif + + GI(1)=U2(1)-U1U2*U1(1) + GI(2)=U2(2)-U1U2*U1(2) + GI(3)=U2(3)-U1U2*U1(3) + + S2=-(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S2.GT.D2.OR.S2.LT.0.) then + goto 90 + endif + + R12(1)=R12(1)+S2*U2(1)-S1*U1(1) + R12(2)=R12(2)+S2*U2(2)-S1*U1(2) + R12(3)=R12(3)+S2*U2(3)-S1*U1(3) + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + + if (D12.GT.LHC) then + goto 90 + endif + + EMAG=VHC*((LHC/D12)**12.-2.*(LHC/D12)**6.+1.)/12. + + DESELF=DESELF+EMAG + + 90 CONTINUE + 80 CONTINUE + + + 40 CONTINUE + 100 CONTINUE + 30 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* + diff --git a/BasicWLC/MCcode/MCsim.f90 b/BasicWLC/MCcode/MCsim.f90 new file mode 100644 index 00000000..b37a2933 --- /dev/null +++ b/BasicWLC/MCcode/MCsim.f90 @@ -0,0 +1,253 @@ +!---------------------------------------------------------------* + +! This subroutine performs a Monte Carlo simulation on the +! polymer chain. + + SUBROUTINE MCsim(R,U,NT,N,NP,NSTEP,BROWN, & + INTON,IDUM,PARA,MCAMP,SUCCESS,MOVEON,WINDOW,SIMTYPE) + + use mt19937, only : grnd + + PARAMETER (PI=3.141592654) ! Value of pi + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION RP(NT,3) ! Bead positions + DOUBLE PRECISION UP(NT,3) ! Tangent vectors + INTEGER N,NP,NT ! Number of beads + INTEGER NSTEP ! Number of MC steps + INTEGER BROWN ! Turn on fluctuations + INTEGER INTON ! Include polymer interactions + +! Variables for the simulation + + INTEGER ISTEP ! Current MC step index + DOUBLE PRECISION PROB ! Calculated test prob + DOUBLE PRECISION TEST ! Random test variable + INTEGER IB ! Test bead + INTEGER IP ! Test polymer + INTEGER IB1 ! Test bead position 1 + INTEGER IT1 ! Index of test bead 1 + INTEGER IB2 ! Test bead position 2 + INTEGER IT2 ! Index of test bead 2 + + INTEGER TEMP + REAL ran1 ! Random number generator + INTEGER IDUM ! Seed for the generator + INTEGER NOW(3) ! Time now (hr,min,sec) + INTEGER I + DOUBLE PRECISION R0(3) + +! Energy variables + + DOUBLE PRECISION DEELAS ! Change in bending energy + DOUBLE PRECISION DESELF ! Change in self energy + DOUBLE PRECISION DEEX ! Change in external energy + DOUBLE PRECISION ENERGY + DOUBLE PRECISION DECOM ! Change in the compression energy + +! MC adaptation variables + + DOUBLE PRECISION MCAMP(6) ! Amplitude of random change + INTEGER MCTYPE ! Type of MC move + INTEGER NADAPT(6) ! Num steps btwn adapt + DOUBLE PRECISION PHIT ! % hits per total steps + DOUBLE PRECISION PDESIRE(6) ! Desired hit rate + INTEGER SUCCESS(6) ! Number of successes + DOUBLE PRECISION MINAMP(6)! Minimum amp to stop + DOUBLE PRECISION MAXAMP(6)! Minimum amp to stop + INTEGER MOVEON(6) ! Is the move active + INTEGER WINDOW(6) ! Size of window for bead selection + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Variables in the simulation + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION FCOM + +! Load the input parameters + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + XIR=PARA(6) + XIU=PARA(7) + LBOX=PARA(8) + FCOM=PARA(9) + VHC=PARA(10) + + MINAMP(1)=0.0*PI + MINAMP(2)=0.0 + MINAMP(3)=0.0*PI + MINAMP(4)=0.0*PI + MINAMP(5)=0.1*PI + MINAMP(6)=0.01 + + MAXAMP(1)=2.*PI + MAXAMP(2)=LBOX + MAXAMP(3)=2.*PI + MAXAMP(4)=2.*PI + MAXAMP(5)=2.*PI + MAXAMP(6)=LBOX + + NADAPT(1)=1000 + NADAPT(2)=1000 + NADAPT(3)=1000 + NADAPT(4)=1000 + NADAPT(5)=1000 + NADAPT(6)=1000 + if (NSTEP.LE.NADAPT(1)) then + NADAPT(1)=NSTEP + endif + if (NSTEP.LE.NADAPT(2)) then + NADAPT(2)=NSTEP + endif + if (NSTEP.LE.NADAPT(3)) then + NADAPT(3)=NSTEP + endif + if (NSTEP.LE.NADAPT(4)) then + NADAPT(4)=NSTEP + endif + if (NSTEP.LE.NADAPT(5)) then + NADAPT(5)=NSTEP + endif + + PDESIRE(1)=0.5 + PDESIRE(2)=0.5 + PDESIRE(3)=0.5 + PDESIRE(4)=0.5 + PDESIRE(5)=0.5 + PDESIRE(6)=0.5 + + SUCCESS(1)=0 + SUCCESS(2)=0 + SUCCESS(3)=0 + SUCCESS(4)=0 + SUCCESS(5)=0 + SUCCESS(6)=0 + + DEELAS=0. + DESELF=0. + DEEX=0. + + +! Begin Monte Carlo simulation + + ISTEP=1 + + DO WHILE (ISTEP.LE.NSTEP) + + DO 10 MCTYPE=1,6 + + if (MOVEON(MCTYPE).EQ.0) then + goto 60 + endif + + call MC_move(R,U,RP,UP,NT,N,NP,IP,IB1,IB2,IT1,IT2,IDUM,MCTYPE,MCAMP) + + if (SIMTYPE.EQ.1.AND.abs(IB2-IB1).LE.1) then + goto 60 + endif + +! Calculate the change in polymer elastic energy using +! SIMTYPE indicates simulation method (WLC=1,SSWLC=2,GC=3) + + call MC_eelas(DEELAS,R,U,RP,UP,NT,N,NP,IP, & + IB1,IB2,IT1,IT2,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + +! Calculate the change in the self-interaction energy + + if (INTON.EQ.1) then + call MC_self(DESELF,R,U,RP,UP,NT,N,NP,IP,IB1,IB2,IT1,IT2,LHC,VHC,LBOX,GAM) + endif + +! Calculate the change in the external force energy + + DECOM=0. + if (IB1.EQ.1.AND.IB2.EQ.N) then + DECOM=FCOM*(sqrt((RP(IT2,1)-RP(IT1,1))**2.+(RP(IT2,2)-RP(IT1,2))**2.+(RP(IT2,3)-RP(IT1,3))**2.) & + -sqrt((R(IT2,1)-R(IT1,1))**2.+(R(IT2,2)-R(IT1,2))**2.+(R(IT2,3)-R(IT1,3))**2.)) + elseif (IB1.EQ.1.AND.IB2.NE.N) then + DECOM=FCOM*(sqrt((R(N*IP,1)-RP(IT1,1))**2.+(R(N*IP,2)-RP(IT1,2))**2.+(R(N*IP,3)-RP(IT1,3))**2.) & + -sqrt((R(N*IP,1)-R(IT1,1))**2.+(R(N*IP,2)-R(IT1,2))**2.+(R(N*IP,3)-R(IT1,3))**2.)) + elseif (IB1.NE.1.AND.IB2.EQ.N) then + DECOM=FCOM*(sqrt((RP(IT2,1)-R(1+N*(IP-1),1))**2.+(RP(IT2,2)-R(1+N*(IP-1),2))**2.+(RP(IT2,3)-R(1+N*(IP-1),3))**2.) & + -sqrt((R(IT2,1)-R(1+N*(IP-1),1))**2.+(R(IT2,2)-R(1+N*(IP-1),2))**2.+(R(IT2,3)-R(1+N*(IP-1),3))**2.)) + endif + +! Change the position if appropriate + + ENERGY=DEELAS+DESELF+DECOM + + PROB=exp(-ENERGY) + if (BROWN.EQ.1) then + TEST=grnd() + else + TEST=1. + endif + if (TEST.LE.PROB) then + DO 20 I=IT1,IT2 + R(I,1)=RP(I,1) + R(I,2)=RP(I,2) + R(I,3)=RP(I,3) + U(I,1)=UP(I,1) + U(I,2)=UP(I,2) + U(I,3)=UP(I,3) + 20 CONTINUE + SUCCESS(MCTYPE)=SUCCESS(MCTYPE)+1 + endif + +! Adapt the amplitude of step every NADAPT steps + + if (mod(ISTEP,NADAPT(MCTYPE)).EQ.0) then + PHIT=real(SUCCESS(MCTYPE))/real(NADAPT(MCTYPE)) + if (PHIT.GT.PDESIRE(MCTYPE)) then + MCAMP(MCTYPE)=MCAMP(MCTYPE)*1.05 + else + MCAMP(MCTYPE)=MCAMP(MCTYPE)*0.95 + endif + if (MCAMP(MCTYPE).GT.MAXAMP(MCTYPE)) then + MCAMP(MCTYPE)=MAXAMP(MCTYPE) + endif + if (MCAMP(MCTYPE).LT.MINAMP(MCTYPE)) then + MCAMP(MCTYPE)=MINAMP(MCTYPE) + endif + + SUCCESS(MCTYPE)=0 + + IB=1 + DO 40 I=1,NP + R0(1)=nint(R(IB,1)/LBOX-0.5)*LBOX + R0(2)=nint(R(IB,2)/LBOX-0.5)*LBOX + R0(3)=nint(R(IB,3)/LBOX-0.5)*LBOX + DO 50 J=1,N + R(IB,1)=R(IB,1)-R0(1) + R(IB,2)=R(IB,2)-R0(2) + R(IB,3)=R(IB,3)-R0(3) + IB=IB+1 + 50 CONTINUE + 40 CONTINUE + + endif + + 60 CONTINUE + + + 10 CONTINUE + + ISTEP=ISTEP+1 + + ENDDO + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/MISCcode/genutil.f90 b/BasicWLC/MISCcode/genutil.f90 new file mode 100644 index 00000000..c0cc7abe --- /dev/null +++ b/BasicWLC/MISCcode/genutil.f90 @@ -0,0 +1,279 @@ +MODULE GENUTIL + ! generally useful utilities + USE MT19937 ! mersenne random number generator + USE QUATUTIL ! utilities for dealing with quaternions + + IMPLICIT NONE + +CONTAINS + + INTEGER FUNCTION STRING2NUM(STRINGIN,APPENDNUM) + ! convert the string to a unique number based on ascii characters + ! the characters SPACE, {,},(,),[,],",`,<,> and all nonprintable characters are ignored + ! at most the last five characters (ignoring the unacceptable characters above) at the end of the string are used + ! any leading "!" do not affect the final number (these map to 0) + ! if APPENDNUM is specificied, only use the last 4 characters of the string as well as the additional number modulo 84 + + IMPLICIT NONE + CHARACTER(LEN=*) :: STRINGIN + CHARACTER(LEN=5) :: STRING + INTEGER, OPTIONAL :: APPENDNUM + INTEGER :: DIGARRAY(5) + INTEGER :: ALLOWED(84) + INTEGER :: N, I, D, COUNT + CHARACTER*84 :: ALLOWEDSTR + + ! set the allowed characters + ALLOWED(1:6) = (/33,35,36,37,38,39/) + ALLOWED(7:24) = (/(I,I=42,59)/) + ALLOWED(25:27) = (/61,63,64/) + ALLOWED(28:53) = (/(I, I=65,90)/) + ALLOWED(54:56) = (/92,94,95/) + ALLOWED(57:82) = (/(I, I=97,122)/) + ALLOWED(83:84) = (/124,126/) + + N = LEN(STRINGIN) + IF (PRESENT(APPENDNUM)) THEN + STRING(1:4) = STRINGIN(N-3:N) + STRING(5:5) = ACHAR(ALLOWED(MOD(APPENDNUM,84)+1)) + ELSE + STRING = STRINGIN(N-4:N) + ENDIF + N = 5 + + + DO I = 1,84 + ALLOWEDSTR(I:I) = ACHAR(ALLOWED(I)) + ENDDO + + DIGARRAY = 0 + COUNT = 0 + DO I = 0,N-1 + D = INDEX(ALLOWEDSTR,STRING(N-I:N-I),.FALSE.) + IF (D.EQ.0) THEN + print*, 'Ignoring character:', D + CYCLE + ENDIF + + DIGARRAY(5-COUNT) = D-1 + COUNT = COUNT + 1 + IF (COUNT.GE.5) EXIT + ENDDO + + STRING2NUM = BASE2DEC(DIGARRAY,5,84) + END FUNCTION STRING2NUM + + INTEGER FUNCTION BASE2DEC(DIGARRAY,N,BASE) + ! given a number in some integer base (specified as a list of digits) + ! convert that number to a decimal integer + ! N is the size of the list + ! if resulting number is too large, wrap around to negative numbers + ! starting from the right, only use as many of the digits as + ! will fit into the resulting integer between -HUGE and HUGE + ! if any digit is greater than base-1, print error and stop + + IMPLICIT NONE + INTEGER, DIMENSION(N) :: DIGARRAY + INTEGER, INTENT(IN) :: N, BASE + INTEGER :: MAXDIG, I, D + + MAXDIG = INT(LOG(2*DBLE(HUGE(BASE))+2)/LOG(DBLE(BASE))) + + BASE2DEC = 0 + DO I = 0, MIN(N-1,MAXDIG-1) + D = DIGARRAY(N-I) + IF (D.EQ.0) CYCLE + IF (D.GT.BASE-1) THEN + PRINT*, 'ERROR in BASE2DEC: digit is bigger than base.', I, D, BASE + STOP 1 + ENDIF + + BASE2DEC = BASE2DEC + D*BASE**I + ENDDO + + END FUNCTION BASE2DEC + + SUBROUTINE INTERPARRAY(ARRAY,NA,COL,VAL,IND,INTERP) + ! for an 2D array with dimensions NA + ! use the values in column COL to interpolate for the value VAL + ! return the index IND such that ARRAY(IND,COL)0 for yes) + INTEGER, PARAMETER :: MAXFIXBEAD = 100 + INTEGER :: NFIXBEAD + INTEGER :: FIXBEAD(MAXFIXBEAD,4) + ! fix all bead positions for top/bottom and or side boundaries + ! 1) top/bottom fixed 2) sides fixed + ! 3) fix positions 4) fix orientations + LOGICAL :: FIXBOUNDARY(4) + ! force a shear deformation + LOGICAL :: SETSHEAR + DOUBLE PRECISION :: SHEARGAMMA + ! start with collapsed structure + LOGICAL :: STARTCOLLAPSE + + LOGICAL :: DOLOCALMOVES +END MODULE KEYS diff --git a/BasicWLC/MISCcode/param.loopL4N10_a2 b/BasicWLC/MISCcode/param.loopL4N10_a2 new file mode 100644 index 00000000..1a7c7eb4 --- /dev/null +++ b/BasicWLC/MISCcode/param.loopL4N10_a2 @@ -0,0 +1,22 @@ +ACTION browndyn +RUNGEKUTTA 4 +NCHAIN 1000 +BDSTEPS 200000 0.5 T +RNGSEED 0 +LS 0.400000 +NPT 11 11 +STRETCHABLE T +SHEARABLE T +COUPLED T +LP 1.560407 +GAM 0.925108 +EPAR 105.621667 +EPERP 130.984758 +EC -10.090547 +FRICT 1D0 0.0008965000 T +DELTSCL 0.022216345092025 +STARTEQUIL 2 +LOOPING 0.20 *.loop.out +INTERPPARAMS T dssWLCparams.txt +DYNAMICREDISC 0 5 1 1 +# \ No newline at end of file diff --git a/BasicWLC/MISCcode/quatutil.f90 b/BasicWLC/MISCcode/quatutil.f90 new file mode 100644 index 00000000..5bad33ff --- /dev/null +++ b/BasicWLC/MISCcode/quatutil.f90 @@ -0,0 +1,832 @@ +MODULE QUATUTIL + ! utilities for dealing with quaternions + ! and other representations of rotation + ! including euler angles, rotation matrices, and alpha+gamma and z-axis-vector representations + + IMPLICIT NONE + LOGICAL :: TESTQUAT = .FALSE. + DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 + ! when z1^2+z2^2 goes below tiny when working with alpha+gamma & zvec coordinates + ! use the v->0 approximation + DOUBLE PRECISION, PARAMETER :: NZTINY=1D-14 + + ! definition of a quaternion class + TYPE QUATERNION + DOUBLE PRECISION :: W, X, Y, Z + END TYPE QUATERNION + + INTERFACE OPERATOR (*) + MODULE PROCEDURE QPRODUCT + END INTERFACE + + INTERFACE OPERATOR (/) + MODULE PROCEDURE QDIVIDE + END INTERFACE + +CONTAINS + SUBROUTINE QUAT2SCREW(QUAT,TRANS,HELCRD) + ! convert from a rotation+translation to screw coordinates + ! (equivalently to overall helix coordinates) + ! returns height, angle, radius, orientation of + ! canonical system relative to helix system (3 euler angles) + TYPE(QUATERNION), INTENT(IN) :: QUAT + DOUBLE PRECISION, INTENT(IN) :: TRANS(3) + DOUBLE PRECISION, INTENT(OUT) :: HELCRD(6) + DOUBLE PRECISION :: THETA, AX(3), TP(3), ST2, CT2, AXT3, A, B, G, NP, NTP + + ! angle-axis representation from quaternion + THETA = 2*ACOS(QUAT%W) + + IF (THETA.EQ.0D0) THEN ! translation only + HELCRD(1) = SQRT(DOT_PRODUCT(TRANS,TRANS)) + HELCRD(2) = 0D0 + HELCRD(3) = 0D0 + HELCRD(4:6) = (/0D0,0D0,0D0/) + RETURN + ENDIF + + ! angle of rotation around screw axis + HELCRD(2) = THETA + + AX = (/QUAT%X,QUAT%Y,QUAT%Z/); + ST2 = SIN(THETA/2) + AX = AX/ST2; ! normalize the axis + + ! shift along screw axis + HELCRD(1) = DOT_PRODUCT(TRANS,AX) + + ! translation in plane perpendicular to axis + TP = TRANS - HELCRD(1)*AX + NTP = SQRT(DOT_PRODUCT(TP,TP)) + + ! radius of screw + NP = NTP/(2*ST2) + HELCRD(3) = NP + + ! cross-product of AX x TP + AXT3 = AX(1)*TP(2) - AX(2)*TP(1) + + ! euler angles of screw axis coord system relative to canonical + A = atan2(AX(1),-AX(2)) + B = ACOS(AX(3)) + CT2 = QUAT%W/ST2 + G = ATAN2(-TP(3)-CT2*AXT3,-AXT3+CT2*TP(3)) + + ! euler angles of canonical system relative to screw axis + HELCRD(4:6) = (/PI-G,B,PI-A/) + END SUBROUTINE QUAT2SCREW + + SUBROUTINE COORDS2QUAT(AG,ZVEC,Q) + ! convert from an alpha+gamma angle and a vector along the z axis + ! to a normalized quaternion + ! note: this doesn't work if beta = pi + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: AG, ZVEC(3) + TYPE(QUATERNION) :: Q + DOUBLE PRECISION :: NZ, ZAX(3), ALPHA,BETA,GAMMA + + NZ = SQRT(DOT_PRODUCT(ZVEC,ZVEC)) + ZAX = ZVEC/NZ + + NZ = ZAX(1)**2+ZAX(2)**2 + + IF (NZ.EQ.0) THEN + CALL EULER2QUAT((/AG,0D0,0D0/),Q) + ELSE + ALPHA = ATAN2(ZAX(1),-ZAX(2)); GAMMA = AG-ALPHA + BETA = ACOS(ZAX(3)) + CALL EULER2QUAT((/ALPHA,BETA,GAMMA/),Q) + ENDIF + + END SUBROUTINE COORDS2QUAT + + SUBROUTINE COORDS2ROTMAT(AG,ZVEC,MAT,DMATAG,DMATZ) + ! convert from coordinates that include the alpha+gamma euler angle + ! and a non-normalized vector along the Z axis in canonical reference system + ! to a rotation matrix + ! if DMATAG and DMATZ are provided, also get derivatives of all the matrix + ! components wrt the coordinates + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: AG, ZVEC(3) + DOUBLE PRECISION, INTENT(OUT) :: MAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMATAG(3,3), DMATZ(3,3,3) + DOUBLE PRECISION :: NZTOT2, NZTOT, NZ, Z1, Z2, Z3 + DOUBLE PRECISION :: Z11,Z22,Z12,Z13,Z23,CAG,SAG + DOUBLE PRECISION :: DXDZ(3,3),DYDZ(3,3) + + IF ((PRESENT(DMATAG).AND..NOT.PRESENT(DMATZ)).OR.& + & (.NOT.PRESENT(DMATAG).AND.PRESENT(DMATZ))) THEN + PRINT*, 'ERROR IN COORDS2ROTMAT: neither or both of DMATAG and DMATZ must be provided' + stop 1 + ENDIF + + MAT = 0D0 + + ! normalize the zaxis + NZTOT2 = DOT_PRODUCT(ZVEC,ZVEC); NZTOT = SQRT(NZTOT2) + MAT(:,3) = ZVEC/NZTOT + Z1 = MAT(1,3); Z2 = MAT(2,3); + Z11 = Z1*Z1; Z22 = Z2*Z2; + NZ = Z11+Z22; + Z3 = MAT(3,3) + Z12 = Z1*Z2; Z23 = Z2*Z3; Z13 = Z1*Z3 + + ! IF (Z3.LT.-1D0+SQRT(NZTINY)) THEN + ! PRINT*, 'ERROR IN COORDS2ROTMAT: have hit gimbal lock with Z axis pointing downward. Not set up to deal with this yet.' + ! STOP 1 + ! ENDIF + + CAG = COS(AG); SAG = SIN(AG) + + !IF (TESTQUAT) PRINT*, 'TESTX1', NZ, NZTINY + IF (NZ.LT.NZTINY) THEN + IF (ZVEC(3).LT.0) THEN + PRINT*, 'PROBLEM IN COORDS2ROTMAT: some z-vector falls along the & + & negative z axis. This causes gimbal lock. & + & If working with a single nucleosome you may be able to & + & avoid this by rotating the entire structure slightly, or & + & by using RANDSTART to start the linker beads in different positions.' + stop 1 + endif + MAT(1,1) = CAG - (Z12*SAG+Z11*CAG)/2 + !if (testquat) print*, 'testx2:', mat(1,1) + MAT(2,1) = SAG - (Z22*SAG+Z12*CAG)/2 + + MAT(1,2) = -SAG+(Z11*SAG-Z12*CAG)/2 + MAT(2,2) = CAG-(Z22*CAG-Z12*SAG)/2 + ELSE + MAT(1,1) = (Z22*CAG-Z12*SAG+Z3*(Z12*SAG+Z11*CAG))/NZ + MAT(2,1) = (-Z12*CAG + Z11*SAG+Z3*(Z22*SAG+Z12*CAG))/NZ + + MAT(1,2) = -(Z22*SAG+Z12*CAG+Z3*(-Z12*CAG+Z11*SAG))/NZ + !if (testquat) print*, 'testx2:', mat(1,2) + MAT(2,2) = (Z12*SAG+Z11*CAG+Z3*(Z22*CAG-Z12*SAG))/NZ + ENDIF + MAT(3,1) = -Z2*SAG-Z1*CAG + MAT(3,2) = -CAG*Z2+SAG*Z1 + + IF (PRESENT(DMATZ)) THEN + DMATZ = 0D0 + + ! derivative of normalized z axis wrt ZVEC coordinates (transposed) + DMATZ(:,3,1) = -ZVEC(1)*MAT(:,3)/NZTOT2 + (/1D0/NZTOT,0D0,0D0/) + DMATZ(:,3,2) = -ZVEC(2)*MAT(:,3)/NZTOT2 + (/0D0,1D0/NZTOT,0D0/) + DMATZ(:,3,3) = -ZVEC(3)*MAT(:,3)/NZTOT2 + (/0D0,0D0,1D0/NZTOT/) + + IF (NZ.LT.NZTINY) THEN + + DXDZ(1,1) = -Z2*SAG/2-Z1*CAG + DXDZ(1,2) = -Z1*SAG/2 + DXDZ(2,1) = -Z2*CAG/2 + DXDZ(2,2) = -Z2*SAG-Z1*CAG/2 + DXDZ(:,3) = 0D0 + + DYDZ(1,1) = Z1*SAG - Z2*CAG/2 + DYDZ(1,2) = -Z1*CAG/2 + DYDZ(2,1) = Z2*SAG/2 + DYDZ(2,2) = -Z2*CAG+Z1*SAG/2 + DYDZ(:,3) = 0D0 + ELSE + ! derivative wrt normalized z axis + DXDZ(1,1) = (-Z2*SAG+Z23*SAG+2*Z13*CAG-2*Z1*MAT(1,1))/NZ + DXDZ(1,2) = (2*Z2*CAG-Z1*SAG+Z13*SAG-2*Z2*MAT(1,1))/NZ + DXDZ(1,3) = (Z12*SAG+Z11*CAG)/NZ + + DXDZ(2,1) = (-Z2*CAG+2*Z1*SAG+Z23*CAG - 2*MAT(2,1)*Z1)/NZ + DXDZ(2,2) = (-Z1*CAG+2*Z23*SAG + Z13*CAG-2*MAT(2,1)*Z2)/NZ + DXDZ(2,3) = (Z22*SAG+Z12*CAG)/NZ + + DYDZ(1,1) = (-Z2*CAG+Z23*CAG-2*Z13*SAG-2*Z1*MAT(1,2))/NZ + DYDZ(1,2) = (-2*Z2*SAG-Z1*CAG+Z13*CAG-2*Z2*MAT(1,2))/NZ + DYDZ(1,3) = (Z12*CAG-Z11*SAG)/NZ + + DYDZ(2,1) = (Z2*SAG+2*Z1*CAG-Z23*SAG-2*Z1*MAT(2,2))/NZ + DYDZ(2,2) = (Z1*SAG+2*Z23*CAG-Z13*SAG-2*Z2*MAT(2,2))/NZ + DYDZ(2,3) = (Z22*CAG-Z12*SAG)/NZ + ENDIF + DXDZ(3,:) = (/-CAG,-SAG,0D0/) + DYDZ(3,:) = (/SAG,-CAG,0D0/) + + ! derivatives of new axes + + CALL DGEMM('N','N',3,3,3,1D0,DXDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,1,:),3) + CALL DGEMM('N','N',3,3,3,1D0,DYDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,2,:),3) + + + !CALL DGEMV('N',3,3,1D0,DZ,3,DMATZTMP(2,1,:),1,0D0,DMATZ(2,1,:),1) + !DMATZ(2,1,:) = DXDZ + ENDIF + + IF (PRESENT(DMATAG)) THEN + DMATAG = 0D0 + + IF (NZ.LT.NZTINY) THEN + DMATAG(1,1) = -SAG-(Z12*CAG-Z11*SAG)/2 + DMATAG(2,1) = CAG-(Z22*CAG-Z12*SAG)/2 + + DMATAG(1,2) = -CAG+(Z11*CAG+Z12*SAG)/2 + DMATAG(2,2) = -SAG+(Z22*SAG+Z12*CAG)/2 + ELSE + DMATAG(1,1) = (-Z22*SAG-Z1*Z2*CAG+Z1*Z23*CAG-Z3*Z11*SAG)/NZ + DMATAG(2,1) = (Z12*SAG+Z11*CAG + Z3*Z22*CAG-Z1*Z23*SAG)/NZ + + DMATAG(1,2) = (-Z22*CAG+Z12*SAG-Z1*Z23*SAG-Z3*Z11*CAG)/NZ + DMATAG(2,2) = (Z12*CAG-Z11*SAG-Z22*Z3*SAG-Z1*Z23*CAG)/NZ + ENDIF + DMATAG(3,1) = -Z2*CAG+Z1*SAG ! dX3/dA + DMATAG(3,2) = SAG*Z2+CAG*Z1! dY3/dA + ENDIF + END SUBROUTINE COORDS2ROTMAT + + ! ----------------- STUFF INVOLVING TREATING QUATERNIONS AS 4-VECTORS ----- + FUNCTION QUAT2QV(Q) + ! convert a quaternion object to a 4-vector + IMPLICIT NONE + DOUBLE PRECISION :: QUAT2QV(4) + TYPE(QUATERNION), INTENT(IN) :: Q + + QUAT2QV = (/Q%W,Q%X,Q%Y,Q%Z/) + END FUNCTION QUAT2QV + + SUBROUTINE ROTQV(THETA,AX,QV,DT) + ! get the quaternion corresponding to rotation around axis AX by angle THETA + ! as a 4-vector (in QV); optionally, also get the derivative wrt theta + ! WARNING: AX assumed to be normalized; does not check for this! + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: THETA, AX(3) + DOUBLE PRECISION, INTENT(OUT) :: QV(4) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DT(4) + DOUBLE PRECISION :: CT, ST + + CT = COS(THETA/2); ST = SIN(THETA/2); + QV(1) = CT + QV(2:4) = ST*AX + + IF (PRESENT(DT)) THEN + DT(1) = -ST/2 + DT(2:4) = CT/2*AX + ENDIF + + END SUBROUTINE ROTQV + + SUBROUTINE QVPTMULT(Q,PT,QP,DQ,DPT) + ! multiply a quaternion by a point in 3-space + ! returns the result in QP + ! optionally, returns derivatives wrt the quaternion components in dQ + ! or wrt point components in DPT + ! WARNING: no normalization happens here + ! WARNING: this is a pretty inefficient way to do things; should fix at some point without resorting to rotation matrices + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: Q(4),PT(3) + DOUBLE PRECISION, INTENT(OUT) :: QP(3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DQ(3,4),DPT(3,3) + DOUBLE PRECISION :: QN, QINV(4),QTMP(4),QTMP2(4) + DOUBLE PRECISION :: MAT(3,3),DMAT(3,3,4) + INTEGER :: I,J + TYPE(QUATERNION) :: QUAT + + QN = DOT_PRODUCT(Q,Q) + QUAT%W = Q(1); QUAT%X = Q(2); QUAT%Y = Q(3); QUAT%Z = Q(4) + IF (PRESENT(DQ)) THEN + CALL QUAT2ROTMAT(QUAT,MAT,dMAT) + ELSE + CALL QUAT2ROTMAT(QUAT,MAT) + ENDIF + DO I = 1,3 + QP(I) = DOT_PRODUCT(MAT(I,:),PT) + IF (PRESENT(DQ)) THEN + DO J = 1,4 + DQ(I,J) = DOT_PRODUCT(dMAT(I,:,J),PT) + ENDDO + ENDIF + ENDDO + + QP = QP/QN + IF (PRESENT(DQ)) THEN + DO I = 1,3 + DO J = 1,4 + DQ(I,J) = (DQ(I,J) - 2*Q(J)*QP(I))/QN + ENDDO + ENDDO + ENDIF + + IF (PRESENT(DPT)) THEN + DPT =MAT/QN + END IF + END SUBROUTINE QVPTMULT + + ! ----------------- STUFF INVOLVING QUATERNION OBJECTS ------------------- + + TYPE(QUATERNION) FUNCTION RHQINTERP(Q1,Q2,F) + ! interpolate from one quaternion to another always in a right-handed sense + ! (relative to the Q1 z-axis) + ! F should be between 0 and 1 + TYPE(QUATERNION) :: Q1, Q2 + DOUBLE PRECISION :: F + DOUBLE PRECISION :: ANG, AX(3), DIR + TYPE(QUATERNION) :: QREL + + ! relative quaternion for Q2 relative to Q1 + QREL = INVQUAT(Q1)*Q2 + + ! angle of rotation + ANG = ACOS(QREL%W)*2 + + ! axis of rotation + AX = (/QREL%X,QREL%Y,QREL%Z/); AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + DIR = DOT_PRODUCT(AX,QUAT2PT(Q1*PTQUAT((/0D0,0D0,1D0/))/Q1)) + + print*, 'testx2:', dir, ang, ax + + IF (DIR.LT.0) THEN + ! rotation axis points away from quaternion axis, so flip it + ANG = -ANG + AX = -AX + ENDIF + + QREL = ROTQUAT(ANG*F,AX) + + RHQINTERP = Q1*QREL + END FUNCTION RHQINTERP + + TYPE(QUATERNION) FUNCTION QSLERP(Q1,Q2,F) + ! Sphreical linear interpolation between two quaternions + ! F should be between 0 and 1 + TYPE(QUATERNION), INTENT(IN) :: Q1, Q2 + DOUBLE PRECISION, INTENT(IN) :: F + DOUBLE PRECISION :: QV1(4), QV2(4), ANG, QVANS(4) + + QV1 = (/Q1%W,Q1%X,Q1%Y,Q1%Z/) + QV2 = (/Q2%W, Q2%X, Q2%Y, Q2%Z/) + + ! angle between them + ANG = ACOS(DOT_PRODUCT(QV1,QV2)) + + QVANS = SIN((1-F)*ANG)/SIN(ANG)*QV1 + SIN(F*ANG)/SIN(ANG)*QV2 + + QSLERP%W = QVANS(1); QSLERP%X = QVANS(2); QSLERP%Y = QVANS(3); QSLERP%Z = QVANS(4); + END FUNCTION QSLERP + + SUBROUTINE QUAT2ROTMAT(Q,MAT,DMAT) + ! convert a quaternion object to a rotation matrix and optionally return derivatives + ! NOTE: no normalization + IMPLICIT NONE + TYPE(QUATERNION) :: Q + DOUBLE PRECISION, INTENT(OUT) :: MAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMAT(3,3,4) + DOUBLE PRECISION :: A,B,C,D,AA,BB,CC,DD,AB,AC,AD,BC,BD,CD + + A = Q%W; B = Q%X; C = Q%Y; D = Q%Z + AA = A*A; BB = B*B; CC = C*C; DD = D*D + AB = 2*A*B; AC = 2*A*C; AD = 2*A*D + BC = 2*B*C; BD = 2*B*D + CD = 2*C*D + + MAT(1,:) = (/AA+BB-CC-DD,BC-AD,AC+BD/) + MAT(2,:) = (/AD+BC,AA-BB+CC-DD,CD-AB/) + MAT(3,:) = (/BD-AC,AB+CD,AA-BB-CC+DD/) + + IF (PRESENT(DMAT)) THEN + dMAT(1,:,1) = (/A,-D,C/) + dMAT(1,:,2) = (/B,C,D/) + dMAT(1,:,3) = (/-C,B,A/) + dMAT(1,:,4) = (/-D,-A,B/) + dMAT(2,:,1) = (/D,A,-B/) + dMAT(2,:,2) = (/C,-B,-A/) + dMAT(2,:,3) = (/B,C,D/) + dMAT(2,:,4) = (/A,-D,C/) + dMAT(3,:,1) = (/-C,B,A/) + dMAT(3,:,2) = (/D,A,-B/) + dMAT(3,:,3) = (/-A,D,-C/) + dMAT(3,:,4) = (/B,C,D/) + dMAT = dMAT*2 + ENDIF + END SUBROUTINE QUAT2ROTMAT + + TYPE(QUATERNION) FUNCTION ROTMAT2QUAT(R) + ! convert from a rotation matrix to a quaternion object + ! following Deibel, 2006 (but with the rotation matrix transposed) + ! R(:,3) has the z axis after rotation is applied, etc. + ! assumes R is orthonormal + IMPLICIT NONE + DOUBLE PRECISION :: R(3,3) + DOUBLE PRECISION :: R11, R22,R33, TMP + + R11 = R(1,1); R22 = R(2,2); R33 = R(3,3) + + IF (R22 .GE.-R33.AND.R11.GE.-R22.AND.R11.GE.-R33) THEN + TMP = SQRT(1+R11+R22+R33) + ROTMAT2QUAT%W = TMP/2 + ROTMAT2QUAT%X = (R(3,2)-R(2,3))/(TMP*2) + ROTMAT2QUAT%Y = (R(1,3)-R(3,1))/(TMP*2) + ROTMAT2QUAT%Z = (R(2,1)-R(1,2))/(TMP*2) + !PRINT*, 'TESTX1Q' + ELSEIF (R22.LE.-R33.AND.R11.GT.R22.AND.R11.GT.R33) THEN + TMP = SQRT(1+R11-R22-R33) + ROTMAT2QUAT%W = (R(3,2)-R(2,3))/(TMP*2) + ROTMAT2QUAT%X = TMP/2 + ROTMAT2QUAT%Y = (R(2,1)+R(1,2))/(TMP*2) + ROTMAT2QUAT%Z = (R(1,3)+R(3,1))/(TMP*2) + !PRINT*, 'TESTX2Q' + ELSEIF (R22.GT.R33.AND.R11.LT.R22.AND.R11.LE.-R33) THEN + TMP = SQRT(1-R11+R22-R33) + ROTMAT2QUAT%W = (R(1,3)-R(3,1))/(TMP*2) + ROTMAT2QUAT%X = (R(2,1)+R(1,2))/(TMP*2) + ROTMAT2QUAT%Y = TMP/2 + ROTMAT2QUAT%Z = (R(3,2)+R(2,3))/(TMP*2) + !PRINT*, 'TESTX3Q' + ELSEIF (R22.LT.R33.AND.R11.LE.-R22.AND.R11.LT.R33) THEN + TMP = SQRT(1D0-R11-R22+R33) + ROTMAT2QUAT%W = (R(2,1)-R(1,2))/(TMP*2) + ROTMAT2QUAT%X = (R(1,3)+R(3,1))/(TMP*2) + ROTMAT2QUAT%Y = (R(3,2)+R(2,3))/(TMP*2) + ROTMAT2QUAT%Z = TMP/2 + !PRINT*, 'TESTX4Q' + ELSE + PRINT*, 'ERROR IN ROTMAT2QUAT: bad rotation matrix' + PRINT*, R(1,:) + PRINT*, R(2,:) + PRINT*, R(3,:) + STOP 1 + ROTMAT2QUAT%W = 0; ROTMAT2QUAT%X = 0; ROTMAT2QUAT%Y = 0; ROTMAT2QUAT%Z = 0 + ENDIF + END FUNCTION ROTMAT2QUAT + + SUBROUTINE EULER2QUAT(EUL,Q,DERV,GETDERV) + ! convert from Euler angles (z-x-z convention) to a quaternion + ! if GETDERV is true, also get the derivatives of the quaternion components + ! with respect to the euler angles (4 rows by 3 columns) + ! WARNING: since the quaternion representation has more parameters, switching from quaternion + ! to euler and back again will not always give the exact same quaternion, though it + ! will give an equivalent one (eg: may invert all components) + + DOUBLE PRECISION, INTENT(IN) :: EUL(3) + TYPE(QUATERNION), INTENT(OUT) :: Q + DOUBLE PRECISION, INTENT(OUT),OPTIONAL :: DERV(4,3) + LOGICAL, INTENT(IN),OPTIONAL :: GETDERV + DOUBLE PRECISION :: CA,SA,CB,SB,CG,SG,ALPHA,GAMMA,BETA + LOGICAL :: FLIPBETA + + BETA = ANGLE2PI(EUL(2)) + FLIPBETA = BETA.GT.PI + ALPHA = EUL(1); GAMMA = EUL(3) + IF (BETA.GT.PI) THEN + BETA = 2*PI-BETA + GAMMA = GAMMA+PI + ALPHA = ALPHA+PI + ENDIF + + ALPHA = ANGLE2PI(ALPHA) + GAMMA = ANGLE2PI(GAMMA) + !IF (QUATTEST) THEN + ! PRINT*, 'TESTXE:', EUL + ! PRINT*, 'A,B,G:',ALPHA,BETA,GAMMA + !ENDIF + + CA = COS(ALPHA/2); SA = SIN(ALPHA/2) + CB = COS(BETA/2); SB = SIN(BETA/2) + CG = COS(GAMMA/2); SG = SIN(GAMMA/2) + + Q%W = CG*CB*CA - SG*CB*SA + Q%X = SG*SB*SA + CG*SB*CA + Q%Y = CG*SB*SA - SG*SB*CA + Q%Z = CG*CB*SA + SG*CB*CA + + IF (PRESENT(DERV)) THEN + IF (GETDERV) THEN + DERV(1,:) = 0.5D0*(/-CG*CB*SA - SG*CB*CA, -CG*SB*CA + SG*SB*SA, -SG*CB*CA - CG*CB*SA/) + DERV(2,:) = 0.5D0*(/SG*SB*CA - CG*SB*SA, SG*CB*SA + CG*CB*CA, CG*SB*SA - SG*SB*CA /) + DERV(3,:) = 0.5D0*(/CG*SB*CA + SG*SB*SA, CG*CB*SA - SG*CB*CA, -SG*SB*SA - CG*SB*CA/) + DERV(4,:) = 0.5D0*(/CG*CB*CA - SG*CB*SA, -CG*SB*SA - SG*SB*CA, -SG*CB*SA + CG*CB*CA/) + ENDIF + IF (FLIPBETA) THEN + DERV(:,2) = -DERV(:,2) + ENDIF + ENDIF + + END SUBROUTINE EULER2QUAT + + SUBROUTINE QUAT2EULER(Q,EUL) + ! get the Euler angles (z-x-z convention) corresponding to a unit quaternion + ! NOTE: the quaternion must already be normalized + ! currently can't handle gimbal lock + TYPE(QUATERNION), INTENT(IN) :: Q + DOUBLE PRECISION, INTENT(OUT) :: EUL(3) + DOUBLE PRECISION :: DUMMY + + EUL(2) = 1 - 2*(Q%X**2+Q%Y**2) + IF (EUL(2).GT.1) THEN + EUL(2) = 0D0 + ELSEIF (EUL(2).LT.-1) THEN + EUL(2) = PI + ELSE + EUL(2) = ACOS(EUL(2)) + ENDIF + + ! deal with the gimbal lock issues + IF (EUL(2).LE.EPSILON(0D0)) THEN + EUL(3) = ATAN2(2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2+Q%Z**2)) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + EUL(1) = 0D0 + RETURN + ELSEIF (EUL(2).GE.PI-EPSILON(0D0)) THEN + EUL(3) = ATAN2(-2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2+Q%Z**2)) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + EUL(1) = 0D0 + RETURN + ENDIF + + DUMMY = Q%W*Q%X-Q%Y*Q%Z + + EUL(1) = ATAN2(Q%W*Q%Y+Q%X*Q%Z, DUMMY) + IF (EUL(1).LT.0) EUL(1) = 2*PI+EUL(1) + + DUMMY = Q%W*Q%X+Q%Y*Q%Z + + EUL(3) = ATAN2(Q%X*Q%Z-Q%W*Q%Y,DUMMY) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + + END SUBROUTINE QUAT2EULER + + FUNCTION QUAT2PT(Q) + ! get the point corresponding to a quaternion + TYPE(QUATERNION) :: Q + DOUBLE PRECISION :: QUAT2PT(3) + + QUAT2PT = (/Q%X,Q%Y,Q%Z/) + END FUNCTION QUAT2PT + + TYPE(QUATERNION) FUNCTION ROTQUAT(THETA,AX) + ! get the quaternion corresponding to rotation around unit axis AX + ! by an angle theta + DOUBLE PRECISION :: THETA, AX(3) + DOUBLE PRECISION :: T2, ST2 + + IF (ABS(SUM(AX**2)-1D0).GT.EPSILON(1d0)*10) THEN + print*, 'ERROR in ROTQUAT: Axis does not have unit norm' + STOP 1 + ENDIF + + T2 = THETA/2; ST2 = SIN(THETA/2) + ROTQUAT%W = COS(T2) + ROTQUAT%X = ST2*AX(1); ROTQUAT%Y = ST2*AX(2); ROTQUAT%Z=ST2*AX(3) + END FUNCTION ROTQUAT + + TYPE(QUATERNION) FUNCTION PTQUAT(P) + ! turn a 3d point into a quaternion + DOUBLE PRECISION :: P(3) + + PTQUAT%W = 0D0; PTQUAT%X = P(1); PTQUAT%Y = P(2); PTQUAT%Z = P(3) + END FUNCTION PTQUAT + + TYPE(QUATERNION) FUNCTION INVQUAT(Q) + ! get the inverse of a quaternion + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: Q + DOUBLE PRECISION :: QN + + QN = Q%W**2+Q%X**2+Q%Y**2+Q%Z**2 + INVQUAT%W = Q%W/QN; INVQUAT%X = -Q%X/QN; INVQUAT%Y=-Q%Y/QN; INVQUAT%Z=-Q%Z/QN + + END FUNCTION INVQUAT + + TYPE(QUATERNION) FUNCTION QDIVIDE(P,Q) + ! multiply P by inverse of Q(in that order) + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: P,Q + TYPE(QUATERNION) :: QINV + DOUBLE PRECISION :: QN + + ! inverse of the 2nd quaternion + QN = Q%W**2+Q%X**2+Q%Y**2+Q%Z**2 + QINV%W = Q%W/QN; QINV%X = -Q%X/QN; QINV%Y=-Q%Y/QN; QINV%Z=-Q%Z/QN + + QDIVIDE = P*QINV + END FUNCTION QDIVIDE + + TYPE(QUATERNION) FUNCTION QPRODUCT(P,Q) + ! quaternion multiplication + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: P, Q + + QPRODUCT%W = P%W*Q%W - P%X*Q%X - P%Y*Q%Y - P%Z*Q%Z + QPRODUCT%X = P%W*Q%X + P%X*Q%W + P%Y*Q%Z - P%Z*Q%Y + QPRODUCT%Y = P%W*Q%Y - P%X*Q%Z + P%Y*Q%W + P%Z*Q%X + QPRODUCT%Z = P%W*Q%Z + P%X*Q%Y - P%Y*Q%X + P%Z*Q%W + + END FUNCTION QPRODUCT + + ! --------- general angle and euler angle stuff ------------- + SUBROUTINE ROTANGAX(ANG,AX,INVEC,OUTVEC,CALCROTMAT,ROTMAT) + ! rotate a 3D vector by angle ANG around axis AX + ! if CALCROTMAT is true, recalculate the rotation matrix + ! otherwise use the provided one + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: ANG, AX(3), INVEC(3) + DOUBLE PRECISION, INTENT(OUT) :: OUTVEC(3) + DOUBLE PRECISION, INTENT(INOUT) :: ROTMAT(3,3) + LOGICAL, INTENT(IN) :: CALCROTMAT + DOUBLE PRECISION :: CT,ST,CT1 + INTEGER :: I + + IF (CALCROTMAT) THEN + CT = COS(ANG); ST = SIN(ANG) + CT1 = 1-CT + ROTMAT(1,:) = (/CT + AX(1)**2*CT1, AX(1)*AX(2)*CT1-AX(3)*ST, AX(1)*AX(3)*CT1+AX(2)*ST/) + ROTMAT(2,:) = (/AX(2)*AX(1)*CT1+AX(3)*ST,CT+AX(2)**2*CT1,AX(2)*AX(3)*CT1-AX(1)*ST/) + ROTMAT(3,:) = (/AX(3)*AX(1)*CT1-AX(2)*ST,AX(3)*AX(2)*CT1+AX(1)*ST, CT+AX(3)**2*CT1/) + ENDIF + + DO I = 1,3 + OUTVEC(I) = DOT_PRODUCT(ROTMAT(I,:),INVEC) + ENDDO + END SUBROUTINE ROTANGAX + + SUBROUTINE EUL2ROTMAT(EUL,ROTMAT,DMAT) + ! get the rotation matrix corresponding to various euler angles + ! and the appropriate derivatives if DMAT is present + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: EUL(3) + DOUBLE PRECISION, INTENT(OUT) :: ROTMAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMAT(3,3,3) + DOUBLE PRECISION :: CA,SA,CB,SB,CG,SG + + CA = COS(EUL(1)); SA = SIN(EUL(1)) + CB = COS(EUL(2)); SB = SIN(EUL(2)) + CG = COS(EUL(3)); SG = SIN(EUL(3)) + + ROTMAT(1,:) = (/CA*CG-SA*CB*SG, -CA*SG-SA*CB*CG, SB*SA/) + ROTMAT(2,:) = (/SA*CG+CA*CB*SG,-SA*SG+CA*CB*CG,-SB*CA/) + ROTMAT(3,:) = (/SB*SG,SB*CG,CB/) + + IF (PRESENT(DMAT)) THEN + dMAT(1,:,1) = (/-SA*CG-CA*CB*SG,SA*SG-CA*CB*CG,SB*CA/) + dMAT(2,:,1) = (/CA*CG-SA*CB*SG,-CA*SG-SA*CB*CG,SB*SA/) + dMAT(3,:,1) = 0D0 + + dMAT(1,:,2) = (/SA*SB*SG,SA*SB*CG,CB*SA/) + dMAT(2,:,2) = (/-CA*SB*SG,-CA*SB*CG,-CB*CA/) + dMAT(3,:,2) = (/CB*SG,CB*CG,-SB/) + + dMAT(1,:,3) = (/-CA*SG-SA*CB*CG,-CA*CG+SA*CB*SG,0D0/) + dMAT(2,:,3) = (/-SA*SG+CA*CB*CG,-SA*CG-CA*CB*SG,0D0/) + dMAT(3,:,3) = (/SB*CG,-SB*SG,0D0/) + ENDIF + END SUBROUTINE EUL2ROTMAT + + SUBROUTINE GETANGLE(IJ,KJ,CST,dCTdIJ,dCTdKJ) + ! get the angle between three points (I-J-K) + ! and, optionally, the derivative of that angle + ! actually this returns the COSINE of the angle and its derivative + ! IJ = I-J; KJ = K-J + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: IJ(3),KJ(3) + DOUBLE PRECISION, INTENT(OUT) :: CST + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: dCTdIJ(3), dCTdKJ(3) + + DOUBLE PRECISION :: DXI, DYI, DZI, DXJ, DYJ, DZJ + DOUBLE PRECISION :: RI2, RJ2, RI, RJ, RIR, RJR + DOUBLE PRECISION :: DXIR,DYIR, DZIR,DXJR,DYJR,DZJR + + DXI=IJ(1); DYI = IJ(2); DZI = IJ(3) + DXJ = KJ(1); DYJ = KJ(2); DZJ = KJ(3) + + RI2=DXI*DXI+DYI*DYI+DZI*DZI + RJ2=DXJ*DXJ+DYJ*DYJ+DZJ*DZJ + RI=SQRT(RI2) + RJ=SQRT(RJ2) + RIR=1/RI + RJR=1/RJ + DXIR=DXI*RIR + DYIR=DYI*RIR + DZIR=DZI*RIR + DXJR=DXJ*RJR + DYJR=DYJ*RJR + DZJR=DZJ*RJR + CST=DXIR*DXJR+DYIR*DYJR+DZIR*DZJR + IF (PRESENT(DCTDIJ)) THEN + dCTdIJ(1)=-(DXIR*CST-DXJR)*RIR + dCTdIJ(2)=-(DYIR*CST-DYJR)*RIR + dCTdIJ(3)=-(DZIR*CST-DZJR)*RIR + ENDIF + IF (PRESENT(DCTDKJ)) THEN + dCTdKJ(1)=-(DXJR*CST-DXIR)*RJR + dCTdKJ(2)=-(DYJR*CST-DYIR)*RJR + dCTdKJ(3)=-(DZJR*CST-DZIR)*RJR + ENDIF + + END SUBROUTINE GETANGLE + + SUBROUTINE GETDIHEDRAL(IJ,JK,LK, PHI, dPdIJ, dPdJK, dPdLK) + ! dihedral angle for 4 atoms I, J, K, L bound in order + ! IJ = I-J; JK = J-K; LK = L-K + ! find the dihedral torsion angle; return it in PHI + ! Also return all derivatives: dP/dIJx, dP/dIJy, dP/dIJz in triplet dPdIJ + ! same with dPdJK, dPdLK + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: IJ(3), JK(3), LK(3) + DOUBLE PRECISION, INTENT(OUT) :: PHI + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: dPdIJ(3), dPdJK(3), dPdLK(3) + DOUBLE PRECISION :: DPDJ(3),DPDI(3),DPDK(3),DPDL(3) + DOUBLE PRECISION :: FX, FY, FZ, GX, GY, GZ, HX, HY, HZ + DOUBLE PRECISION :: AX, AY, AZ, BX, BY, Bz + DOUBLE PRECISION :: RF, RG, RH, RF2, RG2, RH2, RFR, RGR, RHR + DOUBLE PRECISION :: CSTTWO, SNTTWO2, CSTTHREE, SNTTHREE2, SNTTWO2R, SNTTHREE2R + DOUBLE PRECISION :: RA2, RB2, RA2R, RB2R, RABR, CP + DOUBLE PRECISION :: MYTX, MYTY, MYTZ, MYSCALAR + DOUBLE PRECISION :: DUMMY, DUMMY2 + DOUBLE PRECISION :: B1(3), B2(3), B3(3), B12(3), B23(3) + LOGICAL :: NOCOOR = .FALSE. + + + FX=IJ(1) + FY=IJ(2) + FZ=IJ(3) + GX=JK(1) + GY=JK(2) + GZ=JK(3) + HX=LK(1) + HY=LK(2) + HZ=LK(3) + ! A=F x G, B=H x G + AX=FY*GZ-FZ*GY + AY=FZ*GX-FX*GZ + AZ=FX*GY-FY*GX + BX=HY*GZ-HZ*GY + BY=HZ*GX-HX*GZ + BZ=HX*GY-HY*GX + ! RG=|G|, RGR=1/|G| + RG2=GX*GX+GY*GY+GZ*GZ + RG=SQRT(RG2) + RGR=1/RG + ! dae for use in evaluating B-matrix + RF2=FX*FX+FY*FY+FZ*FZ + RF=SQRT(RF2) + RFR=1/RF + RH2=HX*HX+HY*HY+HZ*HZ + RH=SQRT(RH2) + RHR=1/RH + + + CSTTWO=-(FX*GX+FY*GY+FZ*GZ)*RFR*RGR + SNTTWO2=1-CSTTWO*CSTTWO + SNTTWO2R=1/SNTTWO2 + CSTTHREE=(HX*GX+HY*GY+HZ*GZ)*RHR*RGR + SNTTHREE2=1-CSTTHREE*CSTTHREE + SNTTHREE2R=1/SNTTHREE2 + + RA2=AX*AX+AY*AY+AZ*AZ + RB2=BX*BX+BY*BY+BZ*BZ + RA2R=1/RA2 + RB2R=1/RB2 + RABR=SQRT(RA2R*RB2R) + + PHI = ATAN2(-RG*(FX*BX+FY*BY+FZ*BZ),AX*BX+AY*BY+AZ*BZ) + + + IF (PRESENT(DPDIJ).OR.PRESENT(DPDJK).OR.PRESENT(DPDLK)) THEN + DUMMY=RFR*RFR*RGR*SNTTWO2R + dPdI = (/-AX*DUMMY, -AY*DUMMY, -AZ*DUMMY/) + DUMMY=RFR*RFR*RGR*RGR*SNTTWO2R*(RG-RF*CSTTWO) + DUMMY2=RHR*RGR*RGR*SNTTHREE2R*CSTTHREE + dPdJ = (/AX*DUMMY-BX*DUMMY2, AY*DUMMY-BY*DUMMY2, AZ*DUMMY-BZ*DUMMY2/) + DUMMY=RHR*RHR*RGR*SNTTHREE2R + dPdL = (/BX*DUMMY,BY*DUMMY,BZ*DUMMY/) + ENDIF + IF (PRESENT(DPDIJ)) DPDIJ = DPDI + IF (PRESENT(DPDLK)) DPDLK = DPDL + IF (PRESENT(DPDJK)) DPDJK = DPDI + DPDJ + + + END SUBROUTINE GETDIHEDRAL + + DOUBLE PRECISION FUNCTION ANGLE0(ANGLE) + ! convert an angle to one between +/- pi + ! (so keeping it as close as possible to zero) + IMPLICIT NONE + DOUBLE PRECISION :: ANGLE + + ANGLE0 = ANGLE2PI(ANGLE) + IF (ANGLE0.GT.PI) THEN + ANGLE0 = ANGLE0 - 2*PI + ENDIF + END FUNCTION ANGLE0 + + DOUBLE PRECISION FUNCTION ANGLE2PI(ANGLE) + ! convert an angle to one between 0 and 2pi by adding or subtracting multiples of 2pi + IMPLICIT NONE + DOUBLE PRECISION :: ANGLE + INTEGER :: N2PI + + N2PI = INT(ANGLE/(2*PI)) + IF (ANGLE.LT.0) THEN + ANGLE2PI = ANGLE+(-N2PI+1)*2*PI + ELSE + ANGLE2PI = ANGLE - N2PI*2*PI + ENDIF + END FUNCTION ANGLE2PI + +END MODULE QUATUTIL diff --git a/BasicWLC/MISCcode/readkey.f90 b/BasicWLC/MISCcode/readkey.f90 new file mode 100644 index 00000000..8e76ecfb --- /dev/null +++ b/BasicWLC/MISCcode/readkey.f90 @@ -0,0 +1,581 @@ +SUBROUTINE READKEY + ! this subroutine reads in keywords from a parameter file + ! it sets the various global variables defined in KEYS module + ! name of the parameter file is param.* where * is a keyword argument + ! if no keyword argument is supplied, the default is just a file called param + ! The EXTRAPARAMFILES keyword will allow extra parameter files to be + ! read in as well + + USE KEYS + USE INPUTPARAMS, ONLY : READLINE, READA, READF, READI, READO + USE GENUTIL + + IMPLICIT NONE + + ! ---- stuff for inputing the parameter file in free format -------- + CHARACTER*100 :: ARG ! command line argument + INTEGER :: NUMARG ! number of command line arguments + INTEGER :: NITEMS ! number of items on the line in the parameter file + INTEGER :: PF ! input file unit + LOGICAL :: FILEEND=.FALSE. ! done reading file? + CHARACTER*100 :: WORD ! keyword + ! -------------- for reading multiple parameter files -------- + INTEGER, PARAMETER :: MAXNFILES = 10 + CHARACTER*100 :: PARAMFILES(MAXNFILES) + INTEGER :: NPARAMFILES, NPARAMREAD + ! ------ for initializing stuff + INTEGER :: TIMEVAL(8), SEED + !DOUBLE PRECISION :: ROTMAT(3,3) + ! ---------------- temporary variables --------------- + INTEGER :: DUMI, I, TMPI, DUMI1, DUMI2, DUMI3 + CHARACTER*100 :: DUMSTR + LOGICAL :: LDUM, TRACKDISTSET + + ! ------------------------ + ! set variable defaults + ! ------------------------ + ACTION = 'NONE' + RNGSEED = 0 + VERBOSE = .FALSE. + + ! geometry and energy parameters + SHEARABLE = .TRUE. + STRETCHABLE = .TRUE. + COUPLED = .TRUE. + LS = 0.1D0; + LP = 1; + EC = 0; + EPERP = 1D3; + EPAR = 1D3; + GAM = 1D0; + STARTNPT = 100; + MAXNPT = 100; + FORCE = 0D0 + FINITEXT = .FALSE. + FINITSHEAR = 1D-3 + NEDGESEG = 0 + EDGELS = 0.1D0 + EDGELP = 1; + EDGEGAM = 1; + EDGEEPAR = 1D3; + EDGEEPERP = 1D3; + EDGEEC = 0; + + ! input/output + OUTFILE = '*.out' + DUMPSNAPSHOTS = .FALSE. + SNAPSHOTEVERY = 1 + SNAPSHOTFILE = '*.snap.out' + RESTART = .FALSE. + RESTARTFILE = '*.snap.out' + APPENDSNAPSHOTS = .FALSE. + SKIPREAD=1 + STARTEQUIL = .FALSE. + EQUILSAMPLETYPE = 1 + + ! monte carlo + MCPRINTFREQ = 100 + MCTOTSTEPS = 1000 + MCINITSTEPS = 100 + MCSTATSTEPS = 100 + MCOUTPUTFREQ = 100 + + ADJUSTEVERY = 1000 + FACCTARGET = 0.5D0 + FACCTOL = 0.1D0 + ADJUSTSCL = 2D0 + DOREDISC = .FALSE. + DOLOCALMOVES = .FALSE. + OUTPUTBEADWEIGHT = .FALSE. + INTuWEIGHTNPT = 500 + INTRWEIGHTNPT = 50 + + ! brownian dynamics + DELTSCL = 1D-4 + FRICTR = 1D0 + FRICTU = 1D0 + FRICTPERLEN = .FALSE. + FRICTOB = 10D0 + RADOB = 1D0 + MODOB = 1D3 + BDSTEPS = 1000 + BDPRINTEVERY = 1 + BDPRINTLOG = .FALSE. + LOGRTERM = .FALSE. + FIXBEAD1 = .FALSE. + FIXBEADMID = .FALSE. + RUNGEKUTTA = 4 + STRESSFILE = '*.stress.out' + GAUSSIANCHAIN = .FALSE. + DOBROWN = .TRUE. + ! coefficient for the relaxation force in the bead-rod brownian dynamics + ! that keeps the segment length more or less constant + BRCRELAX = 0.1; + USEPSEUDOFORCE = .TRUE. + CONSTMOD = 1D4 + MU = 0D0 + ! tracking looping first passage times + TRACKLOOPING=.FALSE. + LOOPRAD = 0.1 + LOOPFILE= "*.loop.out" + + INITRANGE = 1D0 + + USESTERICS = .FALSE. + STERRAD = 1D0 + STERSKIP=1 + STERMOD = 1D3 + + MINSEGLEN = 0.1D0 + MAXSEGLEN = 5D0 + + ! groups of chains + PARAMFROMSNAPSHOT = .FALSE. + NCONNECT = 0 + NCHAIN = 1 + SQUARELATTICE = .FALSE. + NFORCE = 0 + FORCE = 0D0 + CONNECTIONS = 0 + CONNECTPOS = .TRUE. + CONNECTUVEC = .FALSE. + CONPOSMOD = 1D3 + CONUVECMOD = 1D3 + TRACKDISTSET = .FALSE. + TRACKDIST = 0 + FIXCONNECT = .FALSE. + NFIXBEAD = 0 + FIXBEAD = 0 + FIXBOUNDARY = .FALSE. + SETSHEAR = .FALSE. + SHEARGAMMA = 0D0 + DIAMONDLATTICE = .FALSE. + NDIAMOND = (/1,1/) + WIDTHDIAMOND = -1D0 + LENDIAMOND = 1 + STARTCOLLAPSE = .FALSE. + USEBDENERGY=.FALSE. + + RESTART = .FALSE. + RESTARTFILE = 'start.out' + SKIPREAD = 0 + + EQUILBEADROD = .FALSE. + STARTEQUILLP = 1D0 + + ! ------------------------- + ! Read in all parameter files, starting with the ones specified on command line + ! -------------------------- + + PF = 55 ! i/o unit number to be used for parameter files + + ! get input parameter files from command line + NPARAMFILES = 0 + NUMARG = COMMAND_ARGUMENT_COUNT() + IF (NUMARG==0) THEN + NPARAMFILES = 1 + PARAMFILES(1) = 'param' + ARG = '' + ELSE + DO I = 1,NUMARG + CALL GETARG(I, ARG) + NPARAMFILES = NPARAMFILES + 1 + WRITE(DUMSTR,'(A)') 'param.' //TRIM(ADJUSTL(ARG)) + PARAMFILES(NPARAMFILES) = DUMSTR + ENDDO + ! reset arg to its original value + IF (NUMARG.GT.1) CALL GETARG(1,ARG) + ENDIF + + NPARAMREAD = 0 ! keep track of how many files have been read + DO WHILE (NPARAMREAD.LT.NPARAMFILES) + NPARAMREAD = NPARAMREAD + 1 + + PRINT*, 'Reading parameter file: ', PARAMFILES(NPARAMREAD) + INQUIRE(FILE=PARAMFILES(NPARAMREAD),EXIST=LDUM) + IF (.NOT.LDUM) THEN + PRINT*, 'ERROR in READKEY: Parameter file ', TRIM(ADJUSTL(PARAMFILES(NPARAMREAD))), ' does not exist.' + STOP 1 + ENDIF + OPEN(UNIT=PF, FILE=PARAMFILES(NPARAMREAD), STATUS='OLD') + + ! read in the keywords one line at a time + DO + CALL READLINE(PF,FILEEND,NITEMS) + IF (FILEEND.and.nitems.eq.0) EXIT + + ! skip empty lines + IF (NITEMS.EQ.0) CYCLE + + ! Read in the keyword for this line + CALL READA(WORD,CASESET=1) + + ! Skip any empty lines or any comment lines + IF (WORD(1:1).EQ.'#') CYCLE + + SELECT CASE(WORD) ! pick which keyword + CASE('ACTION') + CALL READA(ACTION, CASESET=1) + CASE('ADJUSTRANGE') + CALL READI(ADJUSTEVERY) + IF (NITEMS.GT.2) CALL READF(FACCTARGET) + IF (NITEMS.GT.3) CALL READF(FACCTOL) + IF (NITEMS.GT.4) CALL READF(ADJUSTSCL) + CASE('BDSTEPS') + CALL READI(BDSTEPS) + IF (NITEMS.GT.2) CALL READF(BDPRINTEVERY) + IF (NITEMS.GT.3) CALL READO(BDPRINTLOG) + CASE('BRCRELAX') + CALL READF(BRCRELAX) + CASE('CONNECT') + NCONNECT = NCONNECT + 1 + IF (NCONNECT.GT.MAXNCONNECT) THEN + PRINT*, 'TOO MANY EXPLICIT CONNECTIONS. RAISE MAXNCONNECT' + STOP 1 + ENDIF + DO DUMI = 1,4 + CALL READI(CONNECTIONS(NCONNECT,DUMI)) + ENDDO + CASE('CONNECTMOD') + CALL READF(CONPOSMOD) + CALL READF(CONUVECMOD) + CASE('CONNECTTYPE') + CALL READO(CONNECTPOS) + CALL READO(CONNECTUVEC) + CASE('CONSTMOD') + CALL READF(CONSTMOD) + CASE('COUPLED') + CALL READO(COUPLED) + CASE('DELTSCL') + CALL READF(DELTSCL) + CASE('DIAMONDLATTICE') + DIAMONDLATTICE = .TRUE. + DO DUMI = 1,2 + CALL READI(NDIAMOND(DUMI)) + ENDDO + CALL READi(LENDIAMOND) + IF (NITEMS.GT.4) CALL READF(WIDTHDIAMOND) + CASE('DOLOCALMOVES') + DOLOCALMOVES = .TRUE. ! do single bead moves for 1-chain MC + CASE('EC') + CALL READF(EC) + CASE('EDGESEGS') + CALL READI(NEDGESEG) + CALL READF(EDGELS) + CALL READF(EDGELP) + CALL READF(EDGEGAM) + CALL READF(EDGEEPAR) + CALL READF(EDGEEPERP) + CALL READF(EDGEEC) + CASE('EPAR') + CALL READF(EPAR) + CASE('EPERP') + CALL READF(EPERP) + CASE('FINITEXT') + IF (NITEMS.GT.1) THEN + CALL READF(FINITSHEAR) + ENDIF + FINITEXT = .TRUE. + CASE('FIXBEAD') + NFIXBEAD = NFIXBEAD + 1 + IF (NFIXBEAD.GT.MAXFIXBEAD) THEN + PRINT*, 'ERROR: too many fixed bead lines' + STOP 1 + ENDIF + CALL READI(FIXBEAD(NFIXBEAD,1)) + IF (NITEMS.GT.2) THEN + CALL READI(FIXBEAD(NFIXBEAD,2)) + CALL READO(LDUM) + IF (LDUM) FIXBEAD(NFIXBEAD,3) = 1 + CALL READO(LDUM) + IF (LDUM) FIXBEAD(NFIXBEAD,4) = 1 + ELSE + FIXBEAD(NFIXBEAD,2) = 1 + ENDIF + CASE('FIXBEAD1') + FIXBEAD1 = .TRUE. + CASE('FIXBEADMID') + FIXBEADMID = .TRUE. + CASE('FIXBOUNDARY') + IF (NITEMS.GT.1) THEN + CALL READO(FIXBOUNDARY(1)) + CALL READO(FIXBOUNDARY(2)) + ENDIF + IF (NITEMS.GT.3) THEN + CALL READO(FIXBOUNDARY(3)) + CALL READO(FIXBOUNDARY(4)) + ENDIF + CASE('FIXCONNECT') + FIXCONNECT=.TRUE. + CASE('FORCE') + NFORCE = NFORCE + 1 + IF (NFORCE.GT.MAXNFORCE) THEN + PRINT*, 'TOO MANY FORCE! RAISE MAXNFORCE.' + stop 1 + ENDIF + CALL READI(FORCEBEAD(NFORCE,1)) + CALL READI(FORCEBEAD(NFORCE,2)) + DO DUMI = 1,3 + CALL READF(FORCE(NFORCE,DUMI)) + ENDDO + CASE('FRICT') + CALL READF(FRICTR) + CALL READF(FRICTU) + IF (NITEMS.GT.3) THEN + CALL READO(FRICTPERLEN) + ENDIF + CASE('GAM') + CALL READF(GAM) + CASE('GAUSSIANCHAIN') + GAUSSIANCHAIN = .TRUE. + CASE('INITRANGE') + DO DUMI = 1,4 + CALL READF(INITRANGE(DUMI)) + ENDDO + CASE('LOGRTERM') + LOGRTERM = .TRUE. + CASE('LOOPING') + TRACKLOOPING = .TRUE. + IF (NITEMS.GT.1) CALL READF(LOOPRAD) + IF (NITEMS.GT.2) CALL READA(LOOPFILE) + CASE('LP') + CALL READF(LP) + CASE('LS') + CALL READF(LS) + CASE('MCPRINTFREQ') + CALL READI(MCPRINTFREQ) + IF (NITEMS.GT.2) THEN + CALL READI(MCOUTPUTFREQ) + ELSE + MCOUTPUTFREQ = MCPRINTFREQ + ENDIF + CASE('MCSTEPS') + CALL READI(MCTOTSTEPS) + IF (NITEMS.GT.2) THEN + CALL READI(MCSTATSTEPS) + endif + IF (NITEMS.GT.3) THEN + CALL READI(MCINITSTEPS) + ENDIF + CASE('MU') + CALL READF(MU) + CASE('NCHAIN') + CALL READI(NCHAIN) + CASE('NOBROWN') + DOBROWN = .FALSE. + CASE('NPT') + ! starting number of points; maximal number + ! if not specified, assuming maximal number is the starting number + CALL READI(STARTNPT) + IF (NITEMS.GT.2) THEN + CALL READI(MAXNPT) + ELSE + MAXNPT = STARTNPT + ENDIF + CASE('OBSTACLE') + CALL READF(RADOB) + CALL READF(MODOB) + CALL READF(FRICTOB) + CASE('OUTFILE') + CALL READA(OUTFILE) + CASE('OUTPUTBEADWEIGHT') + ! output the partition function associated with each mobile bead + ! integrating over R and U vecs separately + OUTPUTBEADWEIGHT = .TRUE. + IF (NITEMS.GT.1) THEN + ! number of integration points in each dim when integrating over u vector + CALL READI(INTUWEIGHTNPT) + ENDIF + IF (NITEMS.GT.2) THEN + CALL READI(INTRWEIGHTNPT) + ENDIF + CASE('PARAMFROMSNAPSHOT') + IF (NITEMS.GT.1) THEN + CALL READO(PARAMFROMSNAPSHOT) + ELSE + PARAMFROMSNAPSHOT = .TRUE. + ENDIF + CASE('REDISCRETIZE') + DOREDISC = .TRUE. + IF (NITEMS.GT.1) CALL READF(MINSEGLEN) + IF (NITEMS.GT.2) CALL READF(MAXSEGLEN) + CASE('RESTART') + RESTART = .TRUE. + IF (NITEMS.GT.1) CALL READA(RESTARTFILE) + IF (NITEMS.GT.2) CALL READI(SKIPREAD) + CASE('RNGSEED') + CALL READI(RNGSEED) + CASE('RUNGEKUTTA') + CALL READI(RUNGEKUTTA) + CASE('SETSHEAR') + SETSHEAR = .TRUE. + CALL READF(SHEARGAMMA) + CASE('SHEARABLE') + CALL READO(SHEARABLE) + CASE('SNAPSHOTS') + DUMPSNAPSHOTS = .TRUE. + IF (NITEMS.GT.1) CALL READI(SNAPSHOTEVERY) + IF (NITEMS.GT.2) CALL READA(SNAPSHOTFILE) + IF (NITEMS.GT.3) CALL READO(APPENDSNAPSHOTS) + CASE('STARTEQUIL') + ! start with properly sampled equilibrium conformations + STARTEQUIL = .TRUE. + IF (NITEMS.GT.1) CALL READI(EQUILSAMPLETYPE) + IF (NITEMS.GT.2) THEN + EQUILBEADROD = .TRUE. + CALL READF(STARTEQUILLP) + ENDIF + CASE('SQUARELATTICE') + SQUARELATTICE = .TRUE. + CASE('STARTCOLLAPSE') + STARTCOLLAPSE = .TRUE. + CASE('STERICS') + USESTERICS = .TRUE. + CALL READF(STERRAD) + IF (NITEMS.GT.2) CALL READI(STERSKIP) + IF (NITEMS.GT.3) CALL READF(STERMOD) + CASE('STRESSFILE') + CALL READA(STRESSFILE) + CASE('STRETCHABLE') + CALL READO(STRETCHABLE) + CASE('TRACKDIST') + TRACKDISTSET = .TRUE. + DO DUMI = 1,4 + CALL READI(TRACKDIST(DUMI)) + ENDDO + CASE('USEBDENERGY') + USEBDENERGY = .TRUE. ! use BD energy for MC calculations + CASE('USEPSEUDOFORCE') + ! use pseudo-potential force for bead-rod BD simulations? + CALL READO(USEPSEUDOFORCE) + CASE('VERBOSE') + CALL READO(VERBOSE) + CASE DEFAULT + print*, 'ERROR: unidentified keyword ', TRIM(WORD), " Will ignore." + END SELECT + ENDDO + CLOSE(PF) + ENDDO + + ! ----- set some more defaults ----- + IF (.NOT.TRACKDISTSET) THEN + TRACKDIST = (/1,1,STARTNPT,1/) + ENDIF + + ! ----------------- + ! check validity of some values, raise errors or adjust as necessary + ! ----------------- + + IF (STARTNPT.LE.0.OR.MAXNPT.LT.STARTNPT) THEN + PRINT*, 'ERROR IN NPT VALUES',STARTNPT,MAXNPT + STOP 1 + ENDIF + IF (EPERP.LT.0) THEN + PRINT*, 'ERROR IN EPERP VALUE', EPERP + STOP 1 + ENDIF + IF (EPAR.LT.0) THEN + PRINT*, 'ERROR IN EPAR VALUE', EPAR + STOP 1 + ENDIF + IF (LS.LT.0) THEN + PRINT*, 'ERROR IN LS VALUE', LS + STOP 1 + ENDIF + IF (LP.LT.0) THEN + PRINT*, 'ERROR IN LP VALUE', LP + STOP 1 + ENDIF + + IF (DIAMONDLATTICE) THEN + ! reset number of chains and length of chains based on diamond lattice + NCHAIN = 2*(NDIAMOND(1)+NDIAMOND(2)-1) + MAXNPT = 2*MINVAL(NDIAMOND)*LENDIAMOND + 1 + IF (WIDTHDIAMOND.LT.0) THEN + WIDTHDIAMOND = GAM*LS*LENDIAMOND/SQRT(2D0)*2 + ENDIF + PRINT*, 'Recalculating nchain and maxnpt for diamond lattice:', NCHAIN, MAXNPT, WIDTHDIAMOND + ENDIF + + IF (TRACKDIST(1).LE.0.OR.TRACKDIST(1).GT.MAXNPT& + & .OR.TRACKDIST(3).LE.0.OR.TRACKDIST(3).GT.MAXNPT& + & .OR.TRACKDIST(2).LE.0.OR.TRACKDIST(2).GT.NCHAIN & + & .OR.TRACKDIST(4).LE.0.OR.TRACKDIST(4).GT.NCHAIN) THEN + PRINT*, 'ERROR: BAD TRACKDIST', TRACKDIST + STOP 1 + ENDIF + + DO DUMI = 1,NFORCE + IF (FORCEBEAD(DUMI,1).LE.0.OR.FORCEBEAD(DUMI,1).GT.MAXNPT & + & .OR.FORCEBEAD(DUMI,2).LE.0.OR.FORCEBEAD(DUMI,2).GT.NCHAIN) THEN + PRINT*, 'ERROR: BAD FORCE', FORCEBEAD(DUMI,:) + STOP 1 + ENDIF + ENDDO + + ! ----------- fix file names ----------- + CALL REPLACESUBSTR(OUTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(SNAPSHOTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(RESTARTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(STRESSFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(LOOPFILE,'*',TRIM(ADJUSTL(ARG))) + ! --------------------------- + + ! Initiate random number generator + IF (RNGSEED.EQ.0) THEN + ! use the current time of day in milliseconds + CALL DATE_AND_TIME(VALUES=TIMEVAL) + SEED = TIMEVAL(5)*3600*1000 + TIMEVAL(6)*60*1000 + TIMEVAL(7)*1000 + TIMEVAL(8) + ELSEIF (RNGSEED.EQ.-1) THEN + ! use the last 5 characters in the command-line argument + SEED = STRING2NUM(TRIM(ADJUSTL(ARG))) + ELSEIF (RNGSEED.EQ.-2) THEN + ! use the last 4 characters in the command-line argument + ! and additionally the millisecond time + CALL DATE_AND_TIME(VALUES=TIMEVAL) + SEED = STRING2NUM(TRIM(ADJUSTL(ARG)),TIMEVAL(8)) + ELSE + ! use this seed directly + SEED = RNGSEED + ENDIF + + print*, 'Initiating Mersenne twister random number generator with seed:', SEED + CALL SGRND(SEED) + + print*, '------------Parameter values : -------------------' + print*, 'ACTION: ', TRIM(ADJUSTL(ACTION)) + print*, 'Output file: ', TRIM(OUTFILE) + IF (DUMPSNAPSHOTS) THEN + PRINT*, 'Dumping snapshot every', SNAPSHOTEVERY,'steps. In file:', TRIM(ADJUSTL(SNAPSHOTFILE)) + ENDIF + IF (RESTART) THEN + PRINT*, 'Restarting from file:', trim(adjustl(RESTARTFILE)) + ENDIF + print*, 'Number of chains:', NCHAIN + print*, 'STARTNPT, MAXNPT, LS:', STARTNPT, MAXNPT,LS + PRINT*, 'LP, GAM, EPAR, EPERP, EC:', LP, GAM, EPAR, EPERP, EC + PRINT*, 'FINITE EXTENSION?:', FINITEXT, FINITSHEAR + PRINT*, 'FRICTION COEFFICIENTS:', FRICTR, FRICTU + PRINT*, 'OBSTACLE:', RADOB,MODOB,FRICTOB + PRINT*, 'CONSTRAINT, STERIC MODULUS, mu:', CONSTMOD, STERMOD, MU + IF (USESTERICS) THEN + PRINT*, 'Using sterics, with radius:', STERRAD + ENDIF + PRINT*, 'NUMBER OF CONNECTIONS:', NCONNECT, SQUARELATTICE + PRINT*, 'FIXED CONNECTIONS?:', FIXCONNECT + print*, 'Tracking distance btwn points:', TRACKDIST + IF (NFIXBEAD.GT.0) THEN + PRINT*, 'FIXED BEADS:' + DO DUMI = 1,NFIXBEAD + PRINT*, FIXBEAD(DUMI,:) + ENDDO + ENDIF + IF (ANY(FIXBOUNDARY)) PRINT*, 'FIXING BOUNDARIES.', FIXBOUNDARY + IF (GAUSSIANCHAIN) PRINT*, 'Treating chain as a plain gaussian with stretch modulus EPAR' + IF (STARTEQUIL) PRINT*, 'Starting from equilibrated configurations.' + IF (NEDGESEG.GT.0) PRINT*, 'For ', NEDGESEG, ' edge segments parameters are:', & + & EDGELS, EDGELP, EDGEGAM, EDGEEPAR, EDGEEPERP, EDGEEC + print*, '----------------------------------------------------' + + +END SUBROUTINE READKEY diff --git a/BasicWLC/SIMcode/debugging.f90 b/BasicWLC/SIMcode/debugging.f90 new file mode 100644 index 00000000..d9d696dc --- /dev/null +++ b/BasicWLC/SIMcode/debugging.f90 @@ -0,0 +1,39 @@ +logical function isanynan(arr) + use globals, only : dp + + implicit none + + real(dp), dimension(:,:) :: arr + integer, dimension(2) :: shapes + integer :: i, j + + shapes = shape(arr) + isanynan = .false. + do i = 1, shapes(1) + do j = 1, shapes(2) + if (isnan(arr(i,j))) then + isanynan = .true. + return + endif + enddo + enddo +endfunction + +logical function b_any(arr) + implicit none + logical :: arr(:,:) + b_any = any(arr) +end function + ! integer :: r + + ! r = rank(arr) + ! isanynan = isanynan_helper(arr, r) +! end function + +! logical isanynan_helper(arr, rank) + ! real(REAL64), intent(in), dimension(*) :: arr + ! integer, intent(in) :: rank + ! integer, dimension(rank) :: sizes + + ! sizes = shape(arr) + ! do i=1, diff --git a/BasicWLC/SIMcode/decim.f90 b/BasicWLC/SIMcode/decim.f90 new file mode 100644 index 00000000..61782ef6 --- /dev/null +++ b/BasicWLC/SIMcode/decim.f90 @@ -0,0 +1,153 @@ +!---------------------------------------------------------------* + + SUBROUTINE decim(R,U,NT,N,NP,PARA,DT) + + PARAMETER (PI=3.141593) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION RT(NT,3) ! Bead positions + DOUBLE PRECISION UT(NT,3) ! Tangent vectors + DOUBLE PRECISION TTOT ! Time of BD simulation + INTEGER N,NP,NT ! Number of beads + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION DEL + DOUBLE PRECISION PVEC(60,8) + INTEGER IND,CRS + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION M + DOUBLE PRECISION DT + INTEGER I,J,IP + DOUBLE PRECISION L,LP + +! Reset the positions and orientations + + IND=1 + do 10 IP=1,NP + I=1 + J=1 + do while (I.LE.N) + RT(IND,1)=R(I+N*(IP-1),1) + RT(IND,2)=R(I+N*(IP-1),2) + RT(IND,3)=R(I+N*(IP-1),3) + UT(IND,1)=U(I+N*(IP-1),1) + UT(IND,2)=U(I+N*(IP-1),2) + UT(IND,3)=U(I+N*(IP-1),3) + I=I+2 + J=J+1 + IND=IND+1 + enddo + 10 CONTINUE + N=J-1 + + do 20 I=1,NP + do 30 J=1,N + IND=J+N*(I-1) + R(IND,1)=RT(IND,1) + R(IND,2)=RT(IND,2) + R(IND,3)=RT(IND,3) + U(IND,1)=UT(IND,1) + U(IND,2)=UT(IND,2) + U(IND,3)=UT(IND,3) + 30 continue + 20 continue + +! Load in the parameters for the simulation + + open (unit=5, file='input/input') + read (unit=5, fmt='(4(/))') + read (unit=5, fmt=*) LP + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) L + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) LBOX + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) LHC + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) VHC + close(5) + L=L/LP + DEL=L/(N-1.) + +! Load the tabulated parameters + + OPEN (UNIT=5,FILE='input/dssWLCparams',STATUS='OLD') + DO 40 I=1,60 + READ(5,*) PVEC(I,1),PVEC(I,2),PVEC(I,3),PVEC(I,4),PVEC(I,5),PVEC(I,6),PVEC(I,7),PVEC(I,8) + 40 CONTINUE + CLOSE(5) + + if (DEL.LT.PVEC(1,1)) then + DEL=PVEC(1,1) + endif + if (DEL.GT.PVEC(60,1)) then + DEL=PVEC(60,1) + endif + + CRS=0 + IND=1 + do while (CRS.EQ.0) + if (DEL.LE.PVEC(IND,1)) then + CRS=1 + else + IND=IND+1 + endif + enddo + + I=2 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EB=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=3 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + GAM=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=4 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EPAR=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=5 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EPERP=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=6 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + ETA=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=7 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + XIU=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + +! I=8 +! M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) +! DT=XIU*(M*(DEL-PVEC(IND,1))+PVEC(IND,I)) + + EB=EB/DEL + EPAR=EPAR/DEL + EPERP=EPERP/DEL + GAM=DEL*GAM + + XIU=XIU*L/N + XIR=L/N + DT=0.5*XIU/(EPERP*GAM**2.) + + PARA(1)=EB + PARA(2)=EPAR + PARA(3)=EPERP + PARA(4)=GAM + PARA(5)=ETA + PARA(6)=XIR + PARA(7)=XIU + PARA(8)=LBOX + PARA(9)=LHC + PARA(10)=VHC + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/energy_elas.f90 b/BasicWLC/SIMcode/energy_elas.f90 new file mode 100644 index 00000000..dc5c2f24 --- /dev/null +++ b/BasicWLC/SIMcode/energy_elas.f90 @@ -0,0 +1,78 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the elastic forces for a wormlike +! chain with a stretching potential. The stretch and bend +! moduli are fed along with the bead positions. +! +! Andrew Spakowitz +! Written 9-1-04 + + SUBROUTINE energy_elas(EELAS,R,U,NT,N,NP,PARA) + + DOUBLE PRECISION EELAS(3) ! Elastic force + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION B(NT) ! Tangent vectors + DOUBLE PRECISION UR(NT,3) ! Tangent vectors + DOUBLE PRECISION KAP,EPS ! Elastic props + DOUBLE PRECISION L0 ! Bead separation + DOUBLE PRECISION FCOM(3) ! Compress force + DOUBLE PRECISION FBEND(3) ! Bend force + INTEGER I,J,IB ! Index holders + INTEGER N,NT,NP ! Number of bead + +! Polymer properties + + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + +! Variables for force and torque calculations + + DOUBLE PRECISION DR(3),DRPAR,DRPERP(3) + DOUBLE PRECISION FI(3),TI(3) + DOUBLE PRECISION U1U2,GI(3),DOTGU,HI(3) + +! Calculate the forces and torques + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + + EELAS(1)=0. + EELAS(2)=0. + EELAS(3)=0. + IB=1 + DO 30 I=1,NP + DO 40 J=1,(N-1) + DR(1)=R(IB+1,1)-R(IB,1) + DR(2)=R(IB+1,2)-R(IB,2) + DR(3)=R(IB+1,3)-R(IB,3) + DRPAR=DR(1)*U(IB,1)+DR(2)*U(IB,2)+DR(3)*U(IB,3) + + DRPERP(1)=DR(1)-DRPAR*U(IB,1) + DRPERP(2)=DR(2)-DRPAR*U(IB,2) + DRPERP(3)=DR(3)-DRPAR*U(IB,3) + U1U2=U(IB,1)*U(IB+1,1)+U(IB,2)*U(IB+1,2)+U(IB,3)*U(IB+1,3) + + GI(1)=(U(IB+1,1)-U(IB,1)-ETA*DRPERP(1)) + GI(2)=(U(IB+1,2)-U(IB,2)-ETA*DRPERP(2)) + GI(3)=(U(IB+1,3)-U(IB,3)-ETA*DRPERP(3)) + + EELAS(1)=EELAS(1)+0.5*EB*(GI(1)**2.+GI(2)**2.+GI(3)**2.) + EELAS(2)=EELAS(2)+0.5*EPAR*(DRPAR-GAM)**2. + EELAS(3)=EELAS(3)+0.5*EPERP*(DRPERP(1)**2.+DRPERP(2)**2.+DRPERP(3)**2.) + + IB=IB+1 + 40 CONTINUE + IB=IB+1 + 30 CONTINUE + + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/energy_ponp.f90 b/BasicWLC/SIMcode/energy_ponp.f90 new file mode 100644 index 00000000..8f58a4b9 --- /dev/null +++ b/BasicWLC/SIMcode/energy_ponp.f90 @@ -0,0 +1,147 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the self-interaction of a DNA-like +! molecule as a linear chain with charges along the centerline. +! Within the program is specified the Bjerrum length, the +! Debye length, and the length of hard-core repulsion. Exactly +! as given in AJSclamp4-16-04 and elsewhere. +! +! Corrections to force magnitude made 6-3-04. +! +! Andrew Spakowitz +! Written 1-31-05 + + SUBROUTINE energy_ponp(EPONP,R,NT,N,NP,PARA) + + DOUBLE PRECISION R(NT,3) ! Bead positions + INTEGER N,NT,NP ! Current number of beads + DOUBLE PRECISION EPONP ! Self-interaction force + DOUBLE PRECISION FMAG ! Mag of force + DOUBLE PRECISION RIJ ! Interbead dist + DOUBLE PRECISION EIJ(3) ! Interbead unit vector + INTEGER I, J ! Index holders + INTEGER SKIP ! Bead skip index + +! Variables for the calculation + + DOUBLE PRECISION U1(3),U2(3),U1U2 + DOUBLE PRECISION D1,D2 + DOUBLE PRECISION R12(3),D12,E12(3) + DOUBLE PRECISION S1,S2 + DOUBLE PRECISION GI(3) + INTEGER I1,J1,I2,J2 + INTEGER IB1,IB2 + +! Parameters in the simulation + + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION LHC ! HC length + DOUBLE PRECISION SIGP ! HC diameter + DOUBLE PRECISION VHC ! Potential strengths + DOUBLE PRECISION GAM + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION SUM + DOUBLE PRECISION DT + DOUBLE PRECISION XIR + + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + XIR=PARA(6) + XIU=PARA(7) + LBOX=PARA(8) + LHC=PARA(9) + VHC=PARA(10) + + +! Calculate the self-interaction forces + + EPONP=0. + DO 30 I1=1,(NP-1) + DO 40 J1=1,(N-1) + IB1=J1+N*(I1-1) + DO 50 I2=(I1+1),NP + DO 60 J2=1,(N-1) + IB2=J2+N*(I2-1) + R12(1)=R(IB2,1)-R(IB1,1) + R12(2)=R(IB2,2)-R(IB1,2) + R12(3)=R(IB2,3)-R(IB1,3) + R12(1)=R12(1)-nint(R12(1)/LBOX)*LBOX + R12(2)=R12(2)-nint(R12(2)/LBOX)*LBOX + R12(3)=R12(3)-nint(R12(3)/LBOX)*LBOX + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + if (D12.GT.(3.*GAM)) then + goto 70 + endif + + U1(1)=R(IB1+1,1)-R(IB1,1) + U1(2)=R(IB1+1,2)-R(IB1,2) + U1(3)=R(IB1+1,3)-R(IB1,3) + D1=sqrt(U1(1)**2.+U1(2)**2.+U1(3)**2.) + U1(1)=U1(1)/D1 + U1(2)=U1(2)/D1 + U1(3)=U1(3)/D1 + + U2(1)=R(IB2+1,1)-R(IB2,1) + U2(2)=R(IB2+1,2)-R(IB2,2) + U2(3)=R(IB2+1,3)-R(IB2,3) + D2=sqrt(U2(1)**2.+U2(2)**2.+U2(3)**2.) + U2(1)=U2(1)/D2 + U2(2)=U2(2)/D2 + U2(3)=U2(3)/D2 + + U1U2=U1(1)*U2(1)+U1(2)*U2(2)+U1(3)*U2(3) + if (U1U2.EQ.1.) then + goto 70 + endif + + GI(1)=U1(1)-U1U2*U2(1) + GI(2)=U1(2)-U1U2*U2(2) + GI(3)=U1(3)-U1U2*U2(3) + + S1=(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S1.GT.D1.OR.S1.LT.0.) then + goto 70 + endif + + GI(1)=U2(1)-U1U2*U1(1) + GI(2)=U2(2)-U1U2*U1(2) + GI(3)=U2(3)-U1U2*U1(3) + + S2=-(R12(1)*GI(1)+R12(2)*GI(2)+R12(3)*GI(3))/(1.-U1U2**2.) + + if (S2.GT.D2.OR.S2.LT.0.) then + goto 70 + endif + + R12(1)=R12(1)+S2*U2(1)-S1*U1(1) + R12(2)=R12(2)+S2*U2(2)-S1*U1(2) + R12(3)=R12(3)+S2*U2(3)-S1*U1(3) + + D12=sqrt(R12(1)**2.+R12(2)**2.+R12(3)**2.) + + if (D12.GT.LHC) then + goto 70 + endif + + FMAG=VHC*((LHC/D12)**12.-2.*(LHC/D12)**6.+1.)/12. + + EPONP=EPONP+FMAG + + 70 CONTINUE + 60 CONTINUE + 50 CONTINUE + 40 CONTINUE + 30 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* + diff --git a/BasicWLC/SIMcode/gasdev.f90 b/BasicWLC/SIMcode/gasdev.f90 new file mode 100644 index 00000000..6d59d249 --- /dev/null +++ b/BasicWLC/SIMcode/gasdev.f90 @@ -0,0 +1,24 @@ +FUNCTION gasdev(idum) + INTEGER idum + REAL gasdev + INTEGER iset + REAL fac,gset,rsq,v1,v2,ran2 + SAVE iset,gset + DATA iset/0/ + if (idum.lt.0) iset=0 + if (iset.eq.0) then +1 v1=2.*ran2(idum)-1. + v2=2.*ran2(idum)-1. + rsq=v1**2+v2**2 + if(rsq.ge.1..or.rsq.eq.0.)goto 1 + fac=sqrt(-2.*log(rsq)/rsq) + gset=v1*fac + gasdev=v2*fac + iset=1 + else + gasdev=gset + iset=0 + endif + return +END FUNCTION gasdev + diff --git a/BasicWLC/SIMcode/getpara.f90 b/BasicWLC/SIMcode/getpara.f90 new file mode 100644 index 00000000..0232d706 --- /dev/null +++ b/BasicWLC/SIMcode/getpara.f90 @@ -0,0 +1,151 @@ +! *---------------------------------------------------------------* +! +! subroutine getpara.f95 +! Setup the parameters for the simulation +! +! 1. Determine the simulation type +! 2. Evaluate the polymer elastic parameters +! 3. Determine the parameters for Brownian dynamics simulation +! +! Andrew Spakowitz +! 8/17/15 +! + + SUBROUTINE getpara(PARA,DT,SIMTYPE) + + PARAMETER (PI=3.141593) + + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION DEL + DOUBLE PRECISION PVEC(679,8) + INTEGER IND,CRS + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION REND ! Fixed end-to-end distance (dimensionless) + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION M + DOUBLE PRECISION DT + INTEGER I,N + DOUBLE PRECISION L,LP + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Load in the parameters for the simulation + + open (unit=5, file='input/input') + read (unit=5, fmt='(4(/))') + read (unit=5, fmt=*) LP + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) L + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) LBOX + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) REND + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) VHC + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) N + close(5) + L=L/LP + LP=1.0d0 + DEL=L/(N-1.0d0) + REND=REND*L + +! Load the tabulated parameters + + OPEN (UNIT=5,FILE='input/dssWLCparams',STATUS='OLD') + DO 10 I=1,679 + READ(5,*) PVEC(I,1),PVEC(I,2),PVEC(I,3),PVEC(I,4),PVEC(I,5),PVEC(I,6),PVEC(I,7),PVEC(I,8) + 10 CONTINUE + CLOSE(5) + + +! Setup the parameters for WLC simulation + + if (DEL.LT.PVEC(1,1)) then + EB=LP/DEL + GAM=DEL + XIR=L/N + SIMTYPE=1 + endif + +! Setup the parameters for GC simulation + + if (DEL.GT.PVEC(679,1)) then + EPAR=1.5/(DEL*LP**2.) + GAM=0. + SIMTYPE=3 + XIR=L/N + endif + +! Setup the parameters for ssWLC simulation + + if (DEL.GE.PVEC(1,1).AND.DEL.LE.PVEC(679,1)) then + SIMTYPE=2 + + CRS=0 + IND=1 + do while (CRS.EQ.0) + if (DEL.LE.PVEC(IND,1)) then + CRS=1 + else + IND=IND+1 + endif + enddo + + I=2 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EB=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=3 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + GAM=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=4 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EPAR=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=5 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + EPERP=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=6 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + ETA=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + + I=7 + M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) + XIU=M*(DEL-PVEC(IND,1))+PVEC(IND,I) + +! I=8 +! M=(PVEC(IND,I)-PVEC(IND-1,I))/(PVEC(IND,1)-PVEC(IND-1,1)) +! DT=XIU*(M*(DEL-PVEC(IND,1))+PVEC(IND,I)) + + EB=EB/DEL + EPAR=EPAR/DEL + EPERP=EPERP/DEL + GAM=DEL*GAM + + XIU=XIU*L/N + XIR=L/N + DT=0.5*XIU/(EPERP*GAM**2.) + + endif + + PARA(1)=EB + PARA(2)=EPAR + PARA(3)=EPERP + PARA(4)=GAM + PARA(5)=ETA + PARA(6)=XIR + PARA(7)=XIU + PARA(8)=LBOX + PARA(9)=REND + PARA(10)=DEL + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/globals.f90 b/BasicWLC/SIMcode/globals.f90 new file mode 100644 index 00000000..9b39848c --- /dev/null +++ b/BasicWLC/SIMcode/globals.f90 @@ -0,0 +1,12 @@ +module globals + use, intrinsic :: iso_fortran_env + + implicit none + + private + public :: pi, dp + + integer, parameter :: dp = REAL64 + real(dp), parameter :: pi = 3.1415926535897931_dp + +endmodule diff --git a/BasicWLC/SIMcode/initcond.f90 b/BasicWLC/SIMcode/initcond.f90 new file mode 100644 index 00000000..29baaa1d --- /dev/null +++ b/BasicWLC/SIMcode/initcond.f90 @@ -0,0 +1,150 @@ +! ---------------------------------------------------------------* + +! +! subroutine initcond.f95 +! Set the initial conformation of the polymer chains +! from file or from random initialization. +! +! Andrew Spakowitz +! 8/17/15 + + SUBROUTINE initcond(R,U,NT,N,NP,IDUM,FRMFILE,PARA) + + use globals, only : dp + use mt19937, only : init_genrand ! , grnd + + PARAMETER (PI=3.141593) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + INTEGER N,NP,NT ! Number of beads + DOUBLE PRECISION GAM ! Equil bead separation + DOUBLE PRECISION LBOX ! Box edge length + INTEGER I,J,IB ! Index Holders + REAL ran1 ! Random number generator + INTEGER FRMFILE ! Is conformation in file? + INTEGER INPUT ! Is input file set? + DOUBLE PRECISION RMIN + DOUBLE PRECISION R0(3) + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION ARG + +! Parameters for end constraint + + INTEGER IMID + DOUBLE PRECISION ALPHA + DOUBLE PRECISION REND + DOUBLE PRECISION DEL + +! Variables in the simulation + + DOUBLE PRECISION KAP,EPS ! Elastic properties + DOUBLE PRECISION XI ! Drag coefficients + +! Random number generator initiation + + integer IDUM + character*8 datedum + character*10 timedum + character*5 zonedum + integer seedvalues(8) + +! Setup the choice parameters + + INPUT=1 + +! Seed the random number generator off the computer clock + + call date_and_time(datedum,timedum,zonedum,seedvalues) + +! concatenate filename, time within mins, secs, millisecs to seed random number generator + + IDUM=-seedvalues(5)*1E7-seedvalues(6)*1E5-seedvalues(7)*1E3-seedvalues(8) + OPEN (UNIT = 47, FILE = 'data/mt19337_seed', STATUS = 'NEW') + WRITE(47,*) IDUM + CLOSE(47) + call init_genrand(IDUM) + +! Input the conformation if FRMFILE=1 + + if(FRMFILE.EQ.1)then + OPEN (UNIT = 5, FILE = 'input/initial/r', STATUS = 'OLD') + IB=1 + DO 10 I=1,NP + DO 20 J=1,N + READ(5,*) R(IB,1),R(IB,2),R(IB,3) + IB=IB+1 + 20 CONTINUE + 10 CONTINUE + CLOSE(5) + + OPEN (UNIT = 5, FILE = 'input/initial/u', STATUS = 'OLD') + IB=1 + DO 30 I=1,NP + DO 40 J=1,N + READ(5,*) U(IB,1),U(IB,2),U(IB,3) + IB=IB+1 + 40 CONTINUE + 30 CONTINUE + CLOSE(5) + + endif + +! Set the initial conformation to a straight chain if CHOICE=1 + + if(FRMFILE.EQ.0)then + +! Fix the initial condition + + if (INPUT.EQ.0) then + LBOX=10. + GAM=1. + else + GAM=PARA(4) + LBOX=PARA(8) + endif + +! The initial configuration is supposed to be two line segments, intersecting at +! an angle $\alpha$. The first line is layed along the x-axis with one end at +! $(0,0,0)$, and the other segment starts half the polymer's length along the +! x-axis, with the other end sitting in the $xy$-plane with $x>0$ and $y>0$. + REND=PARA(9) + DEL=PARA(10) + IMID=nint((N+1.)/2.) + ARG = ((REND/DEL)**2.-((N-IMID)**2.+(IMID-1)**2.))/(2.*(IMID-1.)*(N-IMID)) +! prevent numerical domain error in arccos + ARG = max(-1.0_dp, ARG) + ARG = min(1.0_dp, ARG) + ALPHA=acos(ARG) + + IB=1 + DO 50 I=1,NP +! R0(1)=grnd()*LBOX +! R0(2)=grnd()*LBOX +! R0(3)=grnd()*LBOX + DO 50 J=1,N + if (J.LE.IMID) then + R(IB,1)=DEL*(J-1.) + R(IB,2)=0 + R(IB,3)=0 + U(IB,1)=1. + U(IB,2)=0. + U(IB,3)=0. + else + R(IB,1)=DEL*(IMID-1.)+DEL*(J-IMID)*cos(ALPHA) + R(IB,2)=DEL*(J-IMID)*sin(ALPHA) + R(IB,3)=0 + U(IB,1)=cos(ALPHA) + U(IB,2)=sin(ALPHA) + U(IB,3)=0. + endif + IB=IB+1 + 60 CONTINUE + 50 CONTINUE + + endif + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/initial_methyl_profile.f90 b/BasicWLC/SIMcode/initial_methyl_profile.f90 new file mode 100644 index 00000000..7935c343 --- /dev/null +++ b/BasicWLC/SIMcode/initial_methyl_profile.f90 @@ -0,0 +1,18 @@ +subroutine initial_methyl_profile(nt,meth_status,nuc_site) + implicit none + integer, intent(in) :: nt + integer, intent(inout) :: meth_status(nt), nuc_site + integer :: i + + nuc_site = ceiling(real(nt/2.0)) + + do i = 1, nt + meth_status(i) = 1 + end do + + +end + + + + diff --git a/BasicWLC/SIMcode/r_to_erg.f90 b/BasicWLC/SIMcode/r_to_erg.f90 new file mode 100644 index 00000000..dea35702 --- /dev/null +++ b/BasicWLC/SIMcode/r_to_erg.f90 @@ -0,0 +1,76 @@ +!! ---------------------------------------------------------------* + +! Find the energetic terms from R + +! Revised 6-22-04 + + SUBROUTINE r_to_erg(R,NT,N,ECOM,EBEND) + + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(N-1,3) ! Tangent + DOUBLE PRECISION B(N-1) ! Bond length + INTEGER N,NT ! Number of beads + INTEGER I + DOUBLE PRECISION KAP,EPS ! DNA mat props + DOUBLE PRECISION L0 ! Equilibrium + ! bead separation + DOUBLE PRECISION DOT ! Dot product + +! Variables in the tube interaction + + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION RAD ! Radius of int + DOUBLE PRECISION SIGP ! Poly diameter of int + DOUBLE PRECISION FORCE + +! Energy variables + + DOUBLE PRECISION ECOM ! Compression energy + DOUBLE PRECISION EBEND ! Bending energy + DOUBLE PRECISION EEX ! External energy + DOUBLE PRECISION EPONP ! Poly energy + +! Setup the properties + + open (unit=5, file='input/input') + read (unit=5, fmt='(4(/))') + read (unit=5, fmt=*) KAP + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) EPS + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) L0 + close(5) + +! Setup the necessary quantities + + DO 10 I=1,(N-1) + B(I)=sqrt((R(I+1,1)-R(I,1))**2.+(R(I+1,2)-R(I,2))**2.+(R(I+1,3)-R(I,3))**2.) + U(I,1)=(R(I+1,1)-R(I,1))/B(I) + U(I,2)=(R(I+1,2)-R(I,2))/B(I) + U(I,3)=(R(I+1,3)-R(I,3))/B(I) + 10 CONTINUE + + +! Calculate the energetic contributions + + ECOM=0. + DO 30 I=1,(N-1) + ECOM=ECOM+(B(I)-L0)**2. + 30 CONTINUE + ECOM=0.5*KAP*ECOM + + EBEND=0. + DO 40 I=1,(N-2) + DOT=U(I+1,1)*U(I,1)+U(I+1,2)*U(I,2)+U(I+1,3)*U(I,3) + EBEND=EBEND+1.-DOT + 40 CONTINUE + EBEND=EPS*EBEND + +! call energy_ex(EEX,R,N,LHC,VHC,RAD) +! call energy_ponp(EPONP,R,N,LB,LHC,VHC,SIGP) + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/ran1.f90 b/BasicWLC/SIMcode/ran1.f90 new file mode 100644 index 00000000..ab5ce262 --- /dev/null +++ b/BasicWLC/SIMcode/ran1.f90 @@ -0,0 +1,30 @@ +! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! ²ú Éú(0,1) ¾ùÔÈ·Ö²¼Ëæ»úÊý×Ó³ÌÐò +! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + function ran1(idum) + integer idum,ia,im,iq,ir,ntab,ndiv + real ran1,am,eps,rnmx + parameter(ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836,& + ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps) + integer j,k,iv(ntab),iy + save iv,iy + data iv/ntab*0/,iy/0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do j=ntab+8,1,-1 + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + if (j.le.ntab) iv(j)=idum + end do + iy=iv(1) + end if + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + j=1+iy/ndiv + iy=iv(j) + iv(j)=idum + ran1=min(am*iy,rnmx) + end +! ----------------------------------------------------------------------- \ No newline at end of file diff --git a/BasicWLC/SIMcode/ran2.f90 b/BasicWLC/SIMcode/ran2.f90 new file mode 100644 index 00000000..6c86405a --- /dev/null +++ b/BasicWLC/SIMcode/ran2.f90 @@ -0,0 +1,35 @@ + + +FUNCTION RAN2(idum) + INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV + REAL ran2,AM,EPS,RNMX + PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, & + IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, & + NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER idum2,j,k,iv(NTAB),iy + SAVE iv,iy,idum2 + DATA idum2/123456789/, iv/NTAB*0/, iy/0/ + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do j=NTAB+8,1,-1 + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + if (j.le.NTAB) iv(j)=idum + end do + iy=iv(1) + endif + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + k=idum2/IQ2 + idum2=IA2*(idum2-k*IQ2)-k*IR2 + if (idum2.lt.0) idum2=idum2+IM2 + j=1+iy/NDIV + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+IMM1 + ran2=min(AM*iy,RNMX) + return +END function ran2 \ No newline at end of file diff --git a/BasicWLC/SIMcode/sigclear.c b/BasicWLC/SIMcode/sigclear.c new file mode 100644 index 00000000..92961287 --- /dev/null +++ b/BasicWLC/SIMcode/sigclear.c @@ -0,0 +1,6 @@ +#include +#include +void sigclear_(int *signum) +{ + signal(*signum, NULL); +} diff --git a/BasicWLC/SIMcode/stress.f90 b/BasicWLC/SIMcode/stress.f90 new file mode 100644 index 00000000..a803a889 --- /dev/null +++ b/BasicWLC/SIMcode/stress.f90 @@ -0,0 +1,102 @@ +!---------------------------------------------------------------* + +! +! This subroutine calculates the elastic forces for a wormlike +! chain with a stretching potential. The stretch and bend +! moduli are fed along with the bead positions. +! +! Andrew Spakowitz +! Written 9-1-04 + + SUBROUTINE stress(SIG,R,U,NT,N,NP,PARA,INTON,SIMTYPE) + + DOUBLE PRECISION FELAS(NT,3) ! Elastic force + DOUBLE PRECISION FPONP(NT,3) ! Self-interaction force + DOUBLE PRECISION TELAS(NT,3) ! Elastic force + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION L0 ! Bead separation + DOUBLE PRECISION FTOT(3) ! Compress force + DOUBLE PRECISION FBEND(3) ! Bend force + INTEGER INTON ! Include polymer interactions + INTEGER I,J,IB ! Index holders + INTEGER N,NT,NP ! Number of bead + INTEGER SIMTYPE + +! Variables in the simulation + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION DT + +! Variables for force and torque calculations + + DOUBLE PRECISION RCOM(3) ! Center of mass + DOUBLE PRECISION SIG(3,3) + +! Load the input parameters + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + XIR=PARA(6) + XIU=PARA(7) + LBOX=PARA(8) + LHC=PARA(9) + VHC=PARA(10) + + DT=0.0001 + call force_elas(FELAS,TELAS,R,U,NT,N,NP,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + + if (INTON.EQ.1) then + call force_ponp(FPONP,R,NT,N,NP,LHC,VHC,LBOX,GAM,DT,XIR) + endif + + SIG(1,1)=0. + SIG(1,2)=0. + SIG(1,3)=0. + SIG(2,1)=0. + SIG(2,2)=0. + SIG(2,3)=0. + SIG(3,1)=0. + SIG(3,2)=0. + SIG(3,3)=0. + DO 10 I=1,NP + RCOM(1)=0. + RCOM(2)=0. + RCOM(3)=0. + DO 20 J=1,N + IB=J+N*(I-1.) + RCOM(1)=RCOM(1)+R(IB,1)/N + RCOM(2)=RCOM(2)+R(IB,2)/N + RCOM(3)=RCOM(3)+R(IB,3)/N + 20 CONTINUE + + DO 30 J=1,N + IB=J+N*(I-1.) + FTOT(1)=FELAS(IB,1)+INTON*FPONP(IB,1) + FTOT(2)=FELAS(IB,2)+INTON*FPONP(IB,2) + FTOT(3)=FELAS(IB,3)+INTON*FPONP(IB,3) + SIG(1,1)=SIG(1,1)-(R(IB,1)-RCOM(1))*FTOT(1) + SIG(1,2)=SIG(1,2)-(R(IB,1)-RCOM(1))*FTOT(2) + SIG(1,3)=SIG(1,3)-(R(IB,1)-RCOM(1))*FTOT(3) + SIG(2,1)=SIG(2,1)-(R(IB,2)-RCOM(2))*FTOT(1) + SIG(2,2)=SIG(2,2)-(R(IB,2)-RCOM(2))*FTOT(2) + SIG(2,3)=SIG(2,3)-(R(IB,2)-RCOM(2))*FTOT(3) + SIG(3,1)=SIG(3,1)-(R(IB,3)-RCOM(3))*FTOT(1) + SIG(3,2)=SIG(3,2)-(R(IB,3)-RCOM(3))*FTOT(2) + SIG(3,3)=SIG(3,3)-(R(IB,3)-RCOM(3))*FTOT(3) + 30 CONTINUE + 10 CONTINUE + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/stressp.f90 b/BasicWLC/SIMcode/stressp.f90 new file mode 100644 index 00000000..858b3c4e --- /dev/null +++ b/BasicWLC/SIMcode/stressp.f90 @@ -0,0 +1,155 @@ +!! ---------------------------------------------------------------* + +! +! This subroutine calculates the elastic forces for a wormlike +! chain with a stretching potential. The stretch and bend +! moduli are fed along with the bead positions. +! +! Andrew Spakowitz +! Written 9-1-04 + + SUBROUTINE stressp(COR,R,U,R0,U0,NT,N,NP,PARA,INTON,SIMTYPE) + + DOUBLE PRECISION FELAS(NT,3) ! Elastic force + DOUBLE PRECISION FPONP(NT,3) ! Self-interaction force + DOUBLE PRECISION TELAS(NT,3) ! Elastic force + DOUBLE PRECISION FELAS0(NT,3) ! Elastic force + DOUBLE PRECISION FPONP0(NT,3) ! Self-interaction force + INTEGER INTON ! Include polymer interactions + DOUBLE PRECISION TELAS0(NT,3) ! Elastic force + DOUBLE PRECISION R(NT,3) ! Bead positions + DOUBLE PRECISION U(NT,3) ! Tangent vectors + DOUBLE PRECISION R0(NT,3) ! Bead positions + DOUBLE PRECISION U0(NT,3) ! Tangent vectors + DOUBLE PRECISION COR + + DOUBLE PRECISION L0 ! Bead separation + DOUBLE PRECISION FTOT(3) ! Compress force + INTEGER I,J,IB ! Index holders + INTEGER N,NT,NP ! Number of bead + INTEGER SIMTYPE + +! Variables in the simulation + + DOUBLE PRECISION EB,EPAR,EPERP + DOUBLE PRECISION GAM,ETA + DOUBLE PRECISION XIR,XIU + DOUBLE PRECISION LBOX ! Box edge length + DOUBLE PRECISION LHC ! Length of HC int + DOUBLE PRECISION VHC ! HC strength + DOUBLE PRECISION PARA(10) + DOUBLE PRECISION DT + +! Variables for force and torque calculations + + DOUBLE PRECISION RCOM(3) ! Center of mass + DOUBLE PRECISION SIG(3,3) + DOUBLE PRECISION SIG0(3,3) + +! Load the input parameters + + EB=PARA(1) + EPAR=PARA(2) + EPERP=PARA(3) + GAM=PARA(4) + ETA=PARA(5) + XIR=PARA(6) + XIU=PARA(7) + LBOX=PARA(8) + LHC=PARA(9) + VHC=PARA(10) + + COR=0. + + DT=0.0001 + call force_elas(FELAS0,TELAS0,R0,U0,NT,N,NP,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + if (INTON.EQ.1) then + call force_ponp(FPONP0,R0,NT,N,NP,LHC,VHC,LBOX,GAM,DT,XIR) + endif + + call force_elas(FELAS,TELAS,R,U,NT,N,NP,EB,EPAR,EPERP,GAM,ETA,SIMTYPE) + if (INTON.EQ.1) then + call force_ponp(FPONP,R,NT,N,NP,LHC,VHC,LBOX,GAM,DT,XIR) + endif + + DO 10 I=1,NP + RCOM(1)=0. + RCOM(2)=0. + RCOM(3)=0. + DO 20 J=1,N + IB=J+N*(I-1.) + RCOM(1)=RCOM(1)+R(IB,1)/N + RCOM(2)=RCOM(2)+R(IB,2)/N + RCOM(3)=RCOM(3)+R(IB,3)/N + 20 CONTINUE + + SIG(1,1)=0. + SIG(1,2)=0. + SIG(1,3)=0. + SIG(2,1)=0. + SIG(2,2)=0. + SIG(2,3)=0. + SIG(3,1)=0. + SIG(3,2)=0. + SIG(3,3)=0. + DO 30 J=1,N + IB=J+N*(I-1.) + FTOT(1)=FELAS(IB,1)+INTON*FPONP(IB,1) + FTOT(2)=FELAS(IB,2)+INTON*FPONP(IB,2) + FTOT(3)=FELAS(IB,3)+INTON*FPONP(IB,3) + SIG(1,1)=SIG(1,1)-(R(IB,1)-RCOM(1))*FTOT(1) + SIG(1,2)=SIG(1,2)-(R(IB,1)-RCOM(1))*FTOT(2) + SIG(1,3)=SIG(1,3)-(R(IB,1)-RCOM(1))*FTOT(3) + SIG(2,1)=SIG(2,1)-(R(IB,2)-RCOM(2))*FTOT(1) + SIG(2,2)=SIG(2,2)-(R(IB,2)-RCOM(2))*FTOT(2) + SIG(2,3)=SIG(2,3)-(R(IB,2)-RCOM(2))*FTOT(3) + SIG(3,1)=SIG(3,1)-(R(IB,3)-RCOM(3))*FTOT(1) + SIG(3,2)=SIG(3,2)-(R(IB,3)-RCOM(3))*FTOT(2) + SIG(3,3)=SIG(3,3)-(R(IB,3)-RCOM(3))*FTOT(3) + 30 CONTINUE + + RCOM(1)=0. + RCOM(2)=0. + RCOM(3)=0. + DO 40 J=1,N + IB=J+N*(I-1.) + RCOM(1)=RCOM(1)+R0(IB,1)/N + RCOM(2)=RCOM(2)+R0(IB,2)/N + RCOM(3)=RCOM(3)+R0(IB,3)/N + 40 CONTINUE + + SIG0(1,1)=0. + SIG0(1,2)=0. + SIG0(1,3)=0. + SIG0(2,1)=0. + SIG0(2,2)=0. + SIG0(2,3)=0. + SIG0(3,1)=0. + SIG0(3,2)=0. + SIG0(3,3)=0. + DO 50 J=1,N + IB=J+N*(I-1.) + FTOT(1)=FELAS0(IB,1)+INTON*FPONP0(IB,1) + FTOT(2)=FELAS0(IB,2)+INTON*FPONP0(IB,2) + FTOT(3)=FELAS0(IB,3)+INTON*FPONP0(IB,3) + SIG0(1,1)=SIG0(1,1)-(R0(IB,1)-RCOM(1))*FTOT(1) + SIG0(1,2)=SIG0(1,2)-(R0(IB,1)-RCOM(1))*FTOT(2) + SIG0(1,3)=SIG0(1,3)-(R0(IB,1)-RCOM(1))*FTOT(3) + SIG0(2,1)=SIG0(2,1)-(R0(IB,2)-RCOM(2))*FTOT(1) + SIG0(2,2)=SIG0(2,2)-(R0(IB,2)-RCOM(2))*FTOT(2) + SIG0(2,3)=SIG0(2,3)-(R0(IB,2)-RCOM(2))*FTOT(3) + SIG0(3,1)=SIG0(3,1)-(R0(IB,3)-RCOM(3))*FTOT(1) + SIG0(3,2)=SIG0(3,2)-(R0(IB,3)-RCOM(3))*FTOT(2) + SIG0(3,3)=SIG0(3,3)-(R0(IB,3)-RCOM(3))*FTOT(3) + 50 CONTINUE + + COR=COR+SIG(1,2)*SIG0(1,2)+SIG(1,3)*SIG0(1,3)+SIG(2,1)*SIG0(2,1)+SIG(2,3)*SIG0(2,3)+SIG(3,1)*SIG0(3,1)+SIG(3,2)*SIG0(3,2) + + 10 CONTINUE + + COR=COR/6. + + RETURN + END + +!---------------------------------------------------------------* diff --git a/BasicWLC/SIMcode/wlcsim.f90 b/BasicWLC/SIMcode/wlcsim.f90 new file mode 100644 index 00000000..2994a96e --- /dev/null +++ b/BasicWLC/SIMcode/wlcsim.f90 @@ -0,0 +1,383 @@ +!---------------------------------------------------------------* + + PROGRAM wlcsim + +! +! WLC Simulation Package: +! Simulation Package for Brownian dynamics and +! Monte Carlo Simulation +! +! Andrew Spakowitz +! Version 1.0 +! 8/17/2015 +! + +! Variables within the simulation + + implicit none + + external WRITE_COLTIMES ! must declare sighandlers as external + + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: R ! Conformation of polymer chains + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: U ! Conformation of polymer chains + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: R0 ! Conformation of polymer chains + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: U0 ! Conformation of polymer chains + + INTEGER NT ! Number of beads in simulation + INTEGER N ! Number of beads in simulation + INTEGER NP ! Number of polymers in simulation + DOUBLE PRECISION L0 ! Equilibrium segment length + DOUBLE PRECISION ENERGY ! Total energy + DOUBLE PRECISION TIME ! Current time + DOUBLE PRECISION TSAVE ! Time of save point + DOUBLE PRECISION T0,TF ! Initial/final times + DOUBLE PRECISION DT ! Time step size + INTEGER I,J,IB ! Index + INTEGER INDMAX ! Maximum index in series + INTEGER IND ! Ind in series + INTEGER TENS ! Decimal of index + character*5 fileind ! Index of output + character*16 snapnm ! File for output + +! Simulation input variables + + INTEGER FRMFILE ! Initial condition + INTEGER BROWN ! Include Brownian forces + INTEGER INTON ! Include polymer interactions + INTEGER LOGTIME ! Is data recorded in log time? + DOUBLE PRECISION DT0 ! Initial time step size + INTEGER NSTEP,NINIT + +! Monte Carlo variables + + DOUBLE PRECISION MCAMP(6) ! Amplitude of random change + INTEGER MOVEON(6) ! Is the move active + INTEGER WINDOW(6) ! Size of window for bead selection + INTEGER SUCCESS(6) ! Number of successes + +! Energy variables + + DOUBLE PRECISION EELAS(3) ! Elastic energy + DOUBLE PRECISION EPONP ! Poly-poly energy + +! Structure analysis + + DOUBLE PRECISION RCOM(3) ! Center of mass + DOUBLE PRECISION DELR(3) ! Mag of gyration tensor + DOUBLE PRECISION RCOM0(3) ! Init val RCOM + DOUBLE PRECISION DELR0(3) ! Init val DELR + DOUBLE PRECISION DRCOM ! Change in RCOM + DOUBLE PRECISION SIG(3,3) + DOUBLE PRECISION COR + +! Variables in the simulation + + DOUBLE PRECISION PARA(10) + INTEGER SIMTYPE ! Simulation method (WLC=1,SSWLC=2,GC=3) + +! Variables for the random number generators + + INTEGER IDUM ! Seed for the generator + DOUBLE PRECISION MOM(6) + +! Variable to hold time of first collisions between each bead + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: HAS_COLLIDED + DOUBLE PRECISION FPT_DIST ! l1 dist to trigger collision + INTEGER COL_TYPE ! what kind of collision checking to use + +! Variables for tracking methylation profile + INTEGER, ALLOCATABLE, DIMENSION(:):: METH_STATUS ! methylation status of each site: 1 = methylated, 0 = unmethylated + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IN_RXN_RAD + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: PAIRS + DOUBLE PRECISION KM ! rate of methylation + DOUBLE PRECISION KD ! rate of demethylation + DOUBLE PRECISION KTOT ! total rate constant + INTEGER NUC_SITE ! bead index of nucleation site + INTEGER NUM_SPREAD ! total number of spreading events + INTEGER NUM_METHYLATED ! number of methylated sites + INTEGER NUM_DECAY ! total number of decay events + + +! Load in the parameters for the simulation + + open (unit=5, file='input/input') + read (unit=5, fmt='(24(/))') + read (unit=5, fmt=*) N + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) NP + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) TF + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) INDMAX + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) DT + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) FRMFILE + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) BROWN + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) INTON + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) LOGTIME + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) NINIT + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) NSTEP + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) FPT_DIST + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) COL_TYPE + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) KM + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) KD + close(5) + call getpara(PARA,DT,SIMTYPE) + DT0=DT + + NT=N*NP + ALLOCATE(R(NT,3)) + ALLOCATE(U(NT,3)) + ALLOCATE(R0(NT,3)) + ALLOCATE(U0(NT,3)) + if (COL_TYPE.NE.0) then + ALLOCATE(HAS_COLLIDED(NT,NT)) + HAS_COLLIDED = -1.0d+0 + else if (COL_TYPE.EQ.2) then + WRITE(*,*) "Not yet implemented: KD-tree based collision detection." + STOP 1 + else + ALLOCATE(HAS_COLLIDED(1,1)) + HAS_COLLIDED = -1.0d+0 + endif + ALLOCATE(METH_STATUS(NT)) + ALLOCATE(IN_RXN_RAD(NT,NT)) + ALLOCATE(PAIRS(2,NT)) + + NUM_SPREAD = 0 + NUM_DECAY = 0 + +! Setup the initial condition + + call initcond(R,U,NT,N,NP,IDUM,FRMFILE,PARA) + + call initial_methyl_profile(NT,METH_STATUS,NUC_SITE) + + OPEN (UNIT = 1, FILE = 'data/m0', STATUS = 'NEW') + DO I=1,NT + WRITE(1,*) meth_status(I) + ENDDO + CLOSE(1) + + KTOT = 1.0 + NUM_METHYLATED = sum(meth_status) + + PRINT *, 'initial number of methylated sites =', NUM_METHYLATED + + +! Turn on moves for each simulation type + + if (SIMTYPE.EQ.1) then + MCAMP(1)=1. + MCAMP(2)=1. + MCAMP(3)=1. + MCAMP(4)=1. + MCAMP(5)=1. + MCAMP(6)=1. + MOVEON(1)=1 + MOVEON(2)=0 + MOVEON(3)=1 + MOVEON(4)=0 + elseif (SIMTYPE.EQ.2) then + MCAMP(1)=1. + MCAMP(2)=1. + MCAMP(3)=1. + MCAMP(4)=1. + MCAMP(5)=1. + MCAMP(6)=1. + MOVEON(1)=1 + MOVEON(2)=1 + MOVEON(3)=1 + MOVEON(4)=1 + elseif (SIMTYPE.EQ.3) then + MCAMP(1)=1. + MCAMP(2)=1. + MCAMP(3)=1. + MCAMP(4)=1. + MCAMP(5)=1. + MCAMP(6)=1. + MOVEON(1)=1 + MOVEON(2)=1 + MOVEON(3)=1 + MOVEON(4)=0 + endif + +! Turn off whole chain rotation and translation if interactions are off + + if (INTON.EQ.1) then + MOVEON(5)=1 + MOVEON(6)=1 + else + MOVEON(5)=0 + MOVEON(6)=0 + endif + +! Perform an initialization MC simulation + + call MCsim(R,U,NT,N,NP,NINIT,BROWN,INTON,IDUM,PARA,MCAMP, & + SUCCESS,MOVEON,WINDOW,SIMTYPE) + +! Save the conformation and PSI angles + + OPEN (UNIT = 1, FILE = 'data/r0', STATUS = 'NEW') + IB=1 + DO 10 I=1,NP + DO 20 J=1,N + R0(IB,1)=R(IB,1) + R0(IB,2)=R(IB,2) + R0(IB,3)=R(IB,3) + U0(IB,1)=U(IB,1) + U0(IB,2)=U(IB,2) + U0(IB,3)=U(IB,3) + WRITE(1,*) R(IB,1),R(IB,2),R(IB,3) + IB=IB+1 + 20 CONTINUE + 10 CONTINUE + CLOSE(1) + + OPEN (UNIT = 1, FILE = 'data/u0', STATUS = 'NEW') + IB=1 + DO 30 I=1,NP + DO 40 J=1,N + WRITE(1,*) U(IB,1),U(IB,2),U(IB,3) + IB=IB+1 + 40 CONTINUE + 30 CONTINUE + CLOSE(1) + +! Begin simulation + + IND=1 + TIME=0. + +! Open the output files + + OPEN (UNIT = 2, FILE = 'data/out1', STATUS = 'NEW') + OPEN (UNIT = 3, FILE = 'data/out2', STATUS = 'NEW') + OPEN (UNIT = 4, FILE = 'data/out3', STATUS = 'NEW') + + call stress(SIG,R,U,NT,N,NP,PARA,INTON,SIMTYPE) + + WRITE(3,*) real(SIG(1,1)),real(SIG(1,2)),real(SIG(1,3)),real(SIG(2,1)),real(SIG(2,2)) + WRITE(4,*) real(SIG(2,3)),real(SIG(3,1)),real(SIG(3,2)),real(SIG(3,3)) + + DO WHILE (IND.LE.INDMAX) + +! Perform a MC simulation, only if NSTEP.NE.0 + + call MCsim(R,U,NT,N,NP,NSTEP,BROWN,INTON,IDUM,PARA,MCAMP, & + SUCCESS,MOVEON,WINDOW,SIMTYPE) + +! Perform a Brownian dynamics simulation over time step + + if (LOGTIME.EQ.0) then + TSAVE = TF*IND/INDMAX + else + TSAVE = DT0*exp((IND-1.)/(INDMAX-1.)*log(TF/DT0)) + endif + if (NSTEP.EQ.0) then + call BDsim(R,U,NT,N,NP,TIME,TSAVE,DT,BROWN,INTON,IDUM, & + PARA,SIMTYPE,HAS_COLLIDED,FPT_DIST,COL_TYPE, & + METH_STATUS,KM,KD,NUM_SPREAD,IN_RXN_RAD,PAIRS,NUC_SITE,NUM_METHYLATED,NUM_DECAY) + endif + +! Save the conformation and the metrics + + TENS=nint(log10(1.*IND)-0.49999)+1 + write (fileind,'(I5)'), IND + snapnm= 'data/r'//fileind((5-TENS+1):5) + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') + IB=1 + DO 50 I=1,NP + DO 60 J=1,N + WRITE(1,*) R(IB,1),R(IB,2),R(IB,3) + IB=IB+1 + 60 CONTINUE + 50 CONTINUE + CLOSE(1) + + snapnm= 'data/u'//fileind((5-TENS+1):5) + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') + IB=1 + DO 70 I=1,NP + DO 80 J=1,N + WRITE(1,*) U(IB,1),U(IB,2),U(IB,3) + IB=IB+1 + 80 CONTINUE + 70 CONTINUE + CLOSE(1) + + snapnm='data/coltimes' + IF (COL_TYPE.NE.0) then + OPEN (UNIT=1, FILE=snapnm, STATUS='REPLACE') + DO I=1,NT + WRITE(1,*) ( HAS_COLLIDED(i,j), j=1,NT ) + ENDDO + CLOSE(1) + ENDIF + + snapnm='data/m'//fileind((5-TENS+1):5) + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') + DO I=1,NT + WRITE(1,*) METH_STATUS(I) + ENDDO + CLOSE(1) + + snapnm='data/num_spread' + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'REPLACE') + WRITE(1,*) NUM_SPREAD + CLOSE(1) + + snapnm='data/num_decay' + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'REPLACE') + WRITE(1,*) NUM_DECAY + CLOSE(1) + + call stress(SIG,R,U,NT,N,NP,PARA,INTON,SIMTYPE) + call stressp(COR,R,U,R0,U0,NT,N,NP,PARA,INTON,SIMTYPE) + + call energy_elas(EELAS,R,U,NT,N,NP,PARA) + EPONP=0. + if (INTON.EQ.1) then + call energy_ponp(EPONP,R,NT,N,NP,PARA) + endif + WRITE(2,*) real(TIME),real(EELAS(1)),real(EELAS(2)),real(EELAS(3)),real(EPONP),real(COR) + + + WRITE(3,*) real(SIG(1,1)),real(SIG(1,2)),real(SIG(1,3)),real(SIG(2,1)),real(SIG(2,2)) + WRITE(4,*) real(SIG(2,3)),real(SIG(3,1)),real(SIG(3,2)),real(SIG(3,3)) + + PRINT*, '________________________________________' + PRINT*, 'Time point ',IND, ' out of', INDMAX + PRINT*, 'Current time ',TIME + PRINT*, 'Bending energy ', EELAS(1) + PRINT*, 'Par compression energy ', EELAS(2) + PRINT*, 'Perp compression energy ', EELAS(3) + PRINT*, 'Polymer-polymer energy ', EPONP + PRINT*, 'Current number of beads ', N + PRINT*, 'Time step ', DT + print*, 'End-to-end distance poly 1 ', & + sqrt((R(N,1)-R(1,1))**2.+(R(N,2)-R(1,2))**2.+(R(N,3)-R(1,3))**2.) + PRINT*, 'Simulation type ', SIMTYPE + PRINT*, 'Number of spreading events ', NUM_SPREAD + PRINT*, 'Number of methylated sites ', NUM_METHYLATED + PRINT*, 'Number of decay events ', NUM_DECAY + + IND=IND+1 + + ENDDO + END + + +!---------------------------------------------------------------* + diff --git a/BasicWLC/dssWLC/doc/README.aux b/BasicWLC/dssWLC/doc/README.aux new file mode 100644 index 00000000..80809fba --- /dev/null +++ b/BasicWLC/dssWLC/doc/README.aux @@ -0,0 +1,22 @@ +\relax +\@writefile{toc}{\contentsline {section}{\numberline {1}Compilation Instructions}{2}} +\@writefile{toc}{\contentsline {section}{\numberline {2}Usage Instructions}{2}} +\@writefile{toc}{\contentsline {section}{\numberline {3}Examples for a Quick Start}{3}} +\@writefile{toc}{\contentsline {subsection}{\numberline {3.1}Example 1: equilibrium sampling}{3}} +\@writefile{toc}{\contentsline {subsection}{\numberline {3.2}Example 2: Brownian Dynamics}{3}} +\@writefile{toc}{\contentsline {subsection}{\numberline {3.3}Example 3: Looping first-passage time}{4}} +\@writefile{toc}{\contentsline {subsection}{\numberline {3.4}Example 4: Looping first-passage time, with dynamic rediscretization}{4}} +\@writefile{toc}{\contentsline {subsection}{\numberline {3.5}Example 5: Monte Carlo}{4}} +\@writefile{toc}{\contentsline {section}{\numberline {4}Auxiliary Scripts}{4}} +\@writefile{toc}{\contentsline {subsection}{\numberline {4.1}Visualizing structures}{4}} +\@writefile{toc}{\contentsline {section}{\numberline {5}Parameters for the dssWLC model}{5}} +\newlabel{sec:getparams}{{5}{5}} +\@writefile{toc}{\contentsline {section}{\numberline {6}Description of Specific Calculations}{6}} +\newlabel{sec:tasks}{{6}{6}} +\@writefile{toc}{\contentsline {subsection}{\numberline {6.1}EQUILDISTRIB action}{6}} +\@writefile{toc}{\contentsline {subsection}{\numberline {6.2}BROWNDYN action}{7}} +\@writefile{toc}{\contentsline {subsection}{\numberline {6.3}MONTECARLO action}{7}} +\@writefile{toc}{\contentsline {section}{\numberline {7}Keyword Index}{7}} +\newlabel{sec:keywords}{{7}{7}} +\bibstyle{aip} +\bibdata{fiberModel} diff --git a/BasicWLC/dssWLC/doc/README.log b/BasicWLC/dssWLC/doc/README.log new file mode 100644 index 00000000..cb94350a --- /dev/null +++ b/BasicWLC/dssWLC/doc/README.log @@ -0,0 +1,218 @@ +This is pdfTeX, Version 3.1415926-1.40.10 (TeX Live 2009/Debian) (format=pdflatex 2012.4.28) 15 JUN 2013 21:34 +entering extended mode + %&-line parsing enabled. +**README.tex +(./README.tex +LaTeX2e <2009/09/24> +Babel and hyphenation patterns for english, usenglishmax, dumylang, noh +yphenation, loaded. +(/usr/share/texmf-texlive/tex/latex/base/article.cls +Document Class: article 2007/10/19 v1.4h Standard LaTeX document class +(/usr/share/texmf-texlive/tex/latex/base/size12.clo +File: size12.clo 2007/10/19 v1.4h Standard LaTeX file (size option) +) +\c@part=\count79 +\c@section=\count80 +\c@subsection=\count81 +\c@subsubsection=\count82 +\c@paragraph=\count83 +\c@subparagraph=\count84 +\c@figure=\count85 +\c@table=\count86 +\abovecaptionskip=\skip41 +\belowcaptionskip=\skip42 +\bibindent=\dimen102 +) +(/usr/share/texmf-texlive/tex/latex/ltxmisc/url.sty +\Urlmuskip=\muskip10 +Package: url 2006/04/12 ver 3.3 Verb mode for urls, etc. +) +(/usr/share/texmf-texlive/tex/latex/setspace/setspace.sty +Package: setspace 2000/12/01 6.7 Contributed and Supported LaTeX2e package + +Package: `setspace' 6.7 <2000/12/01> +) (/usr/share/texmf-texlive/tex/latex/amsmath/amsmath.sty +Package: amsmath 2000/07/18 v2.13 AMS math features +\@mathmargin=\skip43 + +For additional information on amsmath, use the `?' option. +(/usr/share/texmf-texlive/tex/latex/amsmath/amstext.sty +Package: amstext 2000/06/29 v2.01 + +(/usr/share/texmf-texlive/tex/latex/amsmath/amsgen.sty +File: amsgen.sty 1999/11/30 v2.0 +\@emptytoks=\toks14 +\ex@=\dimen103 +)) +(/usr/share/texmf-texlive/tex/latex/amsmath/amsbsy.sty +Package: amsbsy 1999/11/29 v1.2d +\pmbraise@=\dimen104 +) +(/usr/share/texmf-texlive/tex/latex/amsmath/amsopn.sty +Package: amsopn 1999/12/14 v2.01 operator names +) +\inf@bad=\count87 +LaTeX Info: Redefining \frac on input line 211. +\uproot@=\count88 +\leftroot@=\count89 +LaTeX Info: Redefining \overline on input line 307. +\classnum@=\count90 +\DOTSCASE@=\count91 +LaTeX Info: Redefining \ldots on input line 379. +LaTeX Info: Redefining \dots on input line 382. +LaTeX Info: Redefining \cdots on input line 467. +\Mathstrutbox@=\box26 +\strutbox@=\box27 +\big@size=\dimen105 +LaTeX Font Info: Redeclaring font encoding OML on input line 567. +LaTeX Font Info: Redeclaring font encoding OMS on input line 568. +\macc@depth=\count92 +\c@MaxMatrixCols=\count93 +\dotsspace@=\muskip11 +\c@parentequation=\count94 +\dspbrk@lvl=\count95 +\tag@help=\toks15 +\row@=\count96 +\column@=\count97 +\maxfields@=\count98 +\andhelp@=\toks16 +\eqnshift@=\dimen106 +\alignsep@=\dimen107 +\tagshift@=\dimen108 +\tagwidth@=\dimen109 +\totwidth@=\dimen110 +\lineht@=\dimen111 +\@envbody=\toks17 +\multlinegap=\skip44 +\multlinetaggap=\skip45 +\mathdisplay@stack=\toks18 +LaTeX Info: Redefining \[ on input line 2666. +LaTeX Info: Redefining \] on input line 2667. +) +(/usr/share/texmf-texlive/tex/latex/graphics/color.sty +Package: color 2005/11/14 v1.0j Standard LaTeX Color (DPC) + +(/etc/texmf/tex/latex/config/color.cfg +File: color.cfg 2007/01/18 v1.5 color configuration of teTeX/TeXLive +) +Package color Info: Driver file: pdftex.def on input line 130. + +(/usr/share/texmf-texlive/tex/latex/pdftex-def/pdftex.def +File: pdftex.def 2010/03/12 v0.04p Graphics/color for pdfTeX +\Gread@gobject=\count99 +)) (./README.aux) +\openout1 = `README.aux'. + +LaTeX Font Info: Checking defaults for OML/cmm/m/it on input line 12. +LaTeX Font Info: ... okay on input line 12. +LaTeX Font Info: Checking defaults for T1/cmr/m/n on input line 12. +LaTeX Font Info: ... okay on input line 12. +LaTeX Font Info: Checking defaults for OT1/cmr/m/n on input line 12. +LaTeX Font Info: ... okay on input line 12. +LaTeX Font Info: Checking defaults for OMS/cmsy/m/n on input line 12. +LaTeX Font Info: ... okay on input line 12. +LaTeX Font Info: Checking defaults for OMX/cmex/m/n on input line 12. +LaTeX Font Info: ... okay on input line 12. +LaTeX Font Info: Checking defaults for U/cmr/m/n on input line 12. +LaTeX Font Info: ... okay on input line 12. + +(/usr/share/texmf-texlive/tex/context/base/supp-pdf.mkii +[Loading MPS to PDF converter (version 2006.09.02).] +\scratchcounter=\count100 +\scratchdimen=\dimen112 +\scratchbox=\box28 +\nofMPsegments=\count101 +\nofMParguments=\count102 +\everyMPshowfont=\toks19 +\MPscratchCnt=\count103 +\MPscratchDim=\dimen113 +\MPnumerator=\count104 +\everyMPtoPDFconversion=\toks20 +) (./README.toc) +\tf@toc=\write3 +\openout3 = `README.toc'. + + [1 + +{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] +LaTeX Font Info: Try loading font information for OMS+cmr on input line 26. + +(/usr/share/texmf-texlive/tex/latex/base/omscmr.fd +File: omscmr.fd 1999/05/25 v2.5h Standard LaTeX font definitions +) +LaTeX Font Info: Font shape `OMS/cmr/m/n' in size <12> not available +(Font) Font shape `OMS/cmsy/m/n' tried instead on input line 26. + [2] [3] [4] +Overfull \hbox (36.07521pt too wide) in paragraph at lines 125--125 +[]\OT1/cmtt/m/n/12 [eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams( +del,Nseg)[] + [] + +[5] +Overfull \hbox (97.82524pt too wide) in paragraph at lines 151--151 +[]\OT1/cmtt/m/n/12 [eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams( +del,Nseg,`alpha',a)[] + [] + + +Overfull \hbox (227.5003pt too wide) in paragraph at lines 157--157 +[]\OT1/cmtt/m/n/12 [eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams( +del,Nseg,`intepfile',`dssWLCparams.txt')[] + [] + +[6] [7] +Overfull \hbox (2.35567pt too wide) in paragraph at lines 216--217 +[]\OT1/cmr/m/n/12 value: 1 re-quired in-te-ger (BD-STEPS), 1 op-tional float (B +D-PRINT- + [] + +[8] +Overfull \hbox (38.30537pt too wide) in paragraph at lines 219--220 +[]\OT1/cmr/m/n/12 dafaults: BD-STEPS=1000, BD-PRINT-EV-ERY=1, BD-PRINT-LOG=fals +e + [] + +[9] [10] [11] [12] [13] [14] [15] [16] +Overfull \hbox (18.32333pt too wide) in paragraph at lines 510--511 +\OT1/cmr/m/n/12 EC will be ex-tracted from the in-put snap-shot file (set with +\OT1/cmr/m/it/12 RESTART\OT1/cmr/m/n/12 ) + [] + +[17] +Overfull \hbox (1.7019pt too wide) in paragraph at lines 551--552 +\OT1/cmr/m/n/12 Kutta are im-ple-mented; only 4-th or-der has been ex-ten-sivel +y tested + [] + +[18] +Overfull \hbox (24.69434pt too wide) in paragraph at lines 576--577 +[]\OT1/cmr/m/n/12 1 op-tional in-te-ger (EQUI-L-SAM-PLE-TYPE), 1 op-tional floa +t (STARTE- + [] + +[19] [20] +No file README.bbl. +[21] (./README.aux) ) +Here is how much of TeX's memory you used: + 1499 strings out of 495061 + 17923 string characters out of 1182621 + 72758 words of memory out of 3000000 + 4700 multiletter control sequences out of 15000+50000 + 10449 words of font info for 38 fonts, out of 3000000 for 9000 + 28 hyphenation exceptions out of 8191 + 27i,8n,20p,686b,241s stack positions out of 5000i,500n,10000p,200000b,50000s +< +/usr/share/texmf-texlive/fonts/type1/public/amsfonts/cm/cmmi8.pfb> +Output written on README.pdf (21 pages, 164869 bytes). +PDF statistics: + 110 PDF objects out of 1000 (max. 8388607) + 0 named destinations out of 1000 (max. 500000) + 1 words of extra memory for PDF output out of 10000 (max. 10000000) + diff --git a/BasicWLC/dssWLC/doc/README.pdf b/BasicWLC/dssWLC/doc/README.pdf new file mode 100644 index 00000000..61cfdc65 Binary files /dev/null and b/BasicWLC/dssWLC/doc/README.pdf differ diff --git a/BasicWLC/dssWLC/doc/README.tex b/BasicWLC/dssWLC/doc/README.tex new file mode 100644 index 00000000..af8f72ef --- /dev/null +++ b/BasicWLC/dssWLC/doc/README.tex @@ -0,0 +1,657 @@ +\documentclass[12pt]{article} +\usepackage{url,setspace,amsmath} +\usepackage{color} +%\setlength{\oddsidemargin}{-8mm} +%\setlength{\evensidemargin}{0mm} +%\setlength{\textwidth}{175mm} +%\setlength{\topmargin}{-5mm} +%\setlength{\textheight}{225mm} +%\setlength{\headheight}{0cm} +\setstretch{1} + +\begin{document} +\title{\vspace{-2cm}Documentation for shearableWLC code. Simulations using the dssWLC model.} +\author{E.~F.~Koslover, A.~J.~Spakowitz} +\date{Last updated \today} +\maketitle + +This code can be used to run Brownian Dynamics or Monte Carlo simulations of the dssWLC model. + +\tableofcontents +\newpage + +\section{Compilation Instructions} +To compile and run the program, you will need the following: +\begin{itemize} +\item a compiler capable of handling Fortran90. +The code has been tested with the gfortran compiler. +\item BLAS and LAPACK libraries installed in a place where the compiler knows to look for them +\item Python (version 2.5 or higher) to run various auxiliary scripts + (e.g., for visualization). The scripts have been tested with Python + 2.6.4 only. You will also need the NumPy extension package. +\item Recommended: PyMOL to visualize pdb files. +\end{itemize} + +The code has been tested on Ubuntu Linux only. + +To compile with gfortran, go into the \path=source= directory. Type \verb=make=. +To compile with any other compiler that can handle Fortran90, type +\begin{verbatim} +make FC=compiler +\end{verbatim} +substituting in the command you usually use to call the compiler. + +If the compilation works properly, the executable \path=shearableWLC.exe= will appear in the main directory. + +%% To test that the code is running properly, go into the \path=testing= directory and type +%% \begin{verbatim} +%% ./runalltests.py +%% \end{verbatim} +%% This will run a number of test calculations to make sure everything works properly. The tests will take a few minutes to complete. + +\section{Usage Instructions} +To run the program in the main directory, type: +\begin{verbatim} +./shearableWLC.exe suffix +\end{verbatim} + +Here, \verb=suffix= can be any string up to 100 characters in length. +The program reads in all input information from a file named +\path=param.suffix= where, again, \verb=suffix= is the command-line +argument. If no argument is supplied, it will look for a file named +\path=param=. If the desired parameter file does not exist, the +program will exit with an error. + +The parameters in the input file are given in the format "{\em KEYWORD} value" where the possible keywords and values are described +in Section \ref{sec:keywords}. Each keyword goes on a separate +line. Any line that starts with "\#" is treated as a comment and +ignored. Any blank line is also ignored. The keywords in the parameter +file are not case sensitive. For the most part, the order in which the +keywords are given does not matter. All parameters have default +values, so you need only specify keywords and values when you want to +change something from the default. + +%Instructions for running specific calculations are given in more +detail in Section \ref{sec:tasks}. +Example parameter files for the +different calculations are provided in the \path=examples= directory. + +\section{Examples for a Quick Start} +Example parameter files are located in the \path=examples= directory + +\subsection{Example 1: equilibrium sampling} +Sample a number of chain configurations from the equilibrium distribution. Run this example by typing +\begin{verbatim} +../shearableWLC.exe ex.equildistrib +\end{verbatim} +This example uses a chain where the 2 edge segments on either side have a segment length of $0.1$ and corresponding parameters, whereas all other segments have a segment length of $0.2$. +This will sample 10000 chains in total, and output end-to-end vectors in the first three columns of the output file ex.equildistrib.out. The next 3 columns give the first orientation vector. Snapshots of every $1000^\text{th}$ chain will be output in the \path=ex.equildistrib.snap.out= file, which can then be converted to pdb format as follows: +\begin{verbatim} +../snapshot2pdb.py ex.equildistrib.snap.out +\end{verbatim} +The resulting pdb file (\path=ex.equildistrib.snap.pdb=) can be loaded into PyMOL and colored using the following commands within PyMOL itself. +\begin{verbatim} +load ex.equildistrib.snap.pdb, multiplex=0 +../scripts/viewsnapshots.pml +\end{verbatim} + +\subsection{Example 2: Brownian Dynamics} +Run a Brownian Dynamics simulation for 2000 chains in parallel, keeping track of shear stress correlations in the file \path=ex.browndyn.stress.out=. +The simulation starts from an equilibrium distribution and runs for 10000 steps. +\subsection{Example 3: Looping first-passage time} +Run a Brownian Dynamics simulation to track the first passage time to looping for 1000 chains in parallel. This example uses a chain where the 2 edge segments on either side have a segment length of $0.1$ and corresponding parameters, whereas all other segments have a segment length of $0.2$. The friction coefficients are supplied per unit length, which means the edge beads have half the friction of the 2-nd beads from the edge. Those in turn have half the friction of the inner beads (which correspond to longer segment lengths). The time to looping for each chain is output in the 3rd column of the file \path=ex.loop.loop.out= as each chain loops. + +\subsection{Example 4: Looping first-passage time, with dynamic rediscretization} +Run a Brownian Dynamics simulation to track the first passage time to looping for 1000 chains in parallel. Rediscretize the whole chain dynamically by a factor of 4 (to segment lengths of 0.05) whenever the end-to-end distance goes below 0.4. Coarsen the chain whenever the end-to-end distance goes above 0.5. Parameters are interpolated from the file \path=dssWLCparams.txt=. + +\subsection{Example 5: Monte Carlo} +Run a Monte Carlo simulation of $10^8$ steps for a dssWLC. Output the end-to-end distance every 1000 steps into columns 5-7 of the file \path=ex.montecarlo.out=. + +\section{Auxiliary Scripts} + +\subsection{Visualizing structures} + +The script \path=scripts/snapshot2pdb.py= will convert a snapshot file containing many chain configurations into a concatenated pdb file that can be loaded into pymol. Run this script without any arguments to get usage information. +To load the resulting snapshots into different states to make a movie do ``load snap.pdb, multiplex=0'' in pymol. Color an visualize in pymol using \path=scripts/viewsnapshots.pml=. + +\section{Parameters for the dssWLC model} +\label{sec:getparams} +The Matlab code for calculating the energetic and dynamic parameters for the dssWLC model is located in \path=getparams/=. The relevant function for getting the parameters is \path=dssWLCcalcparams= + +There are three approaches to getting the parameters. Firstly, as described in Koslover and Spakowitz, Soft Matter, 2013, one can optimize of the parameter $\alpha = \eta^2\epsilon_b/\epsilon_\perp$ to get the minimal length scale of accuracy. This can be done for a chain with Nseg segments of length $\Delta = \text{del}$ by running the following in Matlab: + +\begin{verbatim} +[eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams(del,Nseg) +\end{verbatim} + +These calculations can be very slow (taking on the order of 15 min). The first time this is run will be even slower as it needs to generate a tensor of coupling coefficients for spherical harmonics which will then by saved in a .mat file for future use. The size of the matrix used for calculating the structure factor is set with the optional parameter LMAX. Default value is LMAX=10. Smaller values of $\Delta$ require higher values of LMAX. + +The output parameters are, in order, $\epsilon_b, \gamma, \epsilon_\parallel, \epsilon_\perp, \eta, \alpha, \zeta_{ub}, \delta t$. They should be input into the parameter files for the Fortran simulation code as follows: +\begin{eqnarray*} +\text{EB} & \quad & \epsilon_b \\ +\text{GAM} & \quad & \gamma \\ +\text{EPERP} & \quad & \epsilon_\perp + \eta^2\epsilon_b \\ +\text{EPAR} & \quad & \epsilon_\parallel \\ +\text{EC} & \quad & - \eta \epsilon_b \\ +\text{FRICT} & \quad & 1/(\text{Nseg}+1) \quad \zeta_{ub} \\ +\text{DELTSCL} & \quad & \delta t/\zeta_{ub} +\end{eqnarray*} +(assuming that $\zeta_{ub} < 1/(\text{Nseg}+1)$). + +Alternately, one can input the friction coefficients per unit length, which needs to be done in the case where not all segment lengths are equal. If using this format, then even if all segment lengths are equal the edge beads will have have the translational friction of the central beads. +\begin{equation*} +\text{FRICT} \quad 1D0 \quad \zeta_{ub}(\text{Nseg}+1)/(\Delta \text{Nseg}) \quad T +\end{equation*} + +Generally, if running a chain with different segment lengths, one should use the smallest segment length to determine the appropriate values of $\delta t$ and $\zeta_{ub}$. + +Another approach to selecting the parameters is to use a specific value of $\alpha$, which can be done as follows in Matlab for a value $\alpha=a$: +\begin{verbatim} +[eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams(del,Nseg,`alpha',a) +\end{verbatim} +This will run much faster and is generally more stable. + +Finally, the recommended approach is to simply interpolate from the pretabulated values available in \path=getparams/dssWLCparams.txt=. This file lists on each line the values of $\Delta, \epsilon_b, \gamma, \epsilon_\parallel, \epsilon_\perp, \eta, \zeta_u, \delta t/\zeta_u$, respectively. The interpolation can be done via: +\begin{verbatim} +[eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams(del,Nseg,`intepfile',`dssWLCparams.txt') +\end{verbatim} +The tabulated file was generated using optimization over $\alpha$ for $\Delta = 0.01 - 1$, and a constant value of $\alpha$ thereafter for $\Delta = 1 - 4$. The interpolation file was generated using \path=getparams/tabulateparams.m= +%The matrix size used was $\text{LMAX}=14$ for $\Delta < 0.045$ and $\text{LMAX}=10$ otherwise. + +\section{Description of Specific Calculations} +\label{sec:tasks} + +The {\em ACTION} keyword specifies what type of calculation will be +done. The possible actions are EQUILDISTRIB, BROWNDYN, and MONTECARLO, as described below. + +\subsection{EQUILDISTRIB action} + +This generates a bunch of dssWLC chain configurations sampled from an equilibrium distributions. The sampling method is set by the {\em STARTEQUIL} keyword (2 types of rejection sampling or monte carlo). Number of chains sampled is set by {\em MCSTEPS} keyword. Dumping of snapshots is set by the {\em SNAPSHOTS} keyword. End-to-end vectors for all configurations are output into the file set by {\em OUTFILE}. Will also work with a Gaussian chain (see {\em GAUSSIANCHAIN} keyword) and a bead-rod chain (if {\em STRETCHABLE} and {\em SHEARABLE} are set to false). + +\subsection{BROWNDYN action} + +This runs a Brownian Dynamics simulation for a set of chains, keeping track of the shear stress correlation over time. Use {\em NCHAIN} to set the number of chains being run in parallel, {\em BDSTEPS} to set the total number of steps and the printing / output frequency. Use {\em LOOPING} keyword to tabulate first passage times for looping of chain ends. {\em FRICT} keyword sets friction coefficients. {\em DELTSCL} keyword sets the timestep as a multiple of the friction coefficients. Can use {\em STARTEQUIL} keyword to start from an equilibrated set of configurations. Can periodically dump out snapshots of chain configurations. + +\subsection{MONTECARLO action} + +Run a Monte Carlo simulation for a dssWLC chain. Only Monte Carlo of a single chain at a time has been recently tested. Set total number of steps and number of initialization steps with the {\em MCSTEPS} keyword. Set printint / output frequency with {\em MCPRINTFREQ}. Can output snapshots with {\em SNAPSHOTS} keyword. Used {\em ADJUSTRANGE} keyword to set how often step sizes are adjusted. For the most part, this has been supplanted by the equilibrium configuration sampling (EQUILDISTRIB action). However this general procedure can be implemented with additional complications (ie: chain meshes, non-local interactions) which EQUILDISTRIB cannot. +% --------------------------------------------------------- + +%---------------------------------------------------------- +\section{Keyword Index} +\label{sec:keywords} +The code will attempt to read parameters out of a file named \path=param.suffix= where ``suffix'' is the command line argument. If no command line arguments are supplied, it will look for a file named \path=param=. If multiple arguments are supplied, it will read multiple parameter files in sequence. + +The parameter file should have one keyword per line and must end with a blank line. All blank lines and all lines beginning with \# are ignored. For the most part, the order of the lines and the capitalization of the keywords does not matter. All keywords except {\em ACTION} are optional. The default values for each parameter are listed below. If a keyword is supplied, then values may or may not be needed as well. Again, the required and optional value types are listed below. + +Keywords and multiple values are separated by spaces. + +When reading the parameter file, lines longer than 500 characters will be truncated. To continue onto the next line, add ``+++'' at the end of the line to be continued. +No individual keyword or value should be longer than 100 characters. + +Floating point numbers can be formated as $1.0$, $1.1D0$, $10e-1$, $-1.0E+01$, etc., where the exponential notation specifier must be D or E (case insensitive). Integer numbers can also be specified in exponential notation without decimal points (eg: 1000 or 1E3). Logical values can be specified as T, F, TRUE, FALSE, 1, or 0 (with 1 corresponding to true and 0 to false). + +By default, all energy units are in kT. + +\begin{itemize} +% +\item {\it ACTION} + \begin{itemize} + \item value: 1 string of at most 20 characters; no default + \item This keyword sets the overall calculation performed by the program + (see Sec.\ref{sec:tasks}) + \item Possible values are: MONTECARLO, BROWNDYN, EQUILDISTRIB + \end{itemize} +% +\item {\it ADJUSTRANGE} + \begin{itemize} + \item value: 1 required integer (ADJUSTEVERY), 3 optional floats (FACCTARGET, FACCTOL, ADJUSTSCL) + \item When doing a Monte Carlo simulation, how to adjust the step size. + \item The accepted fraction is checked every ADJUSTEVERY steps. If it is outside the range of FACCTARGET $\pm$ FACCTOL, then the step sizes are multiplied or divided by ADJUSTSCL + \item defaults are ADJUSTEVERY=1000, FACCTARGET=0.5, FACCTOL=0.1, ADJUSTSCL=2 + \end{itemize} +% +\item {\it BDSTEPS} + \begin{itemize} + \item value: 1 required integer (BDSTEPS), 1 optional float (BDPRINTEVERY), 1 optional logical (BDPRINTLOG) + \item Sets the total number of Brownian Dynamics steps (BDSTEPS) and how often to print output. + \item If BDPRINTLOG is true then print at logarithmically spaced step numbers, where BDPRINTEVERY sets the multiplicative factor for the spacing. Otherwise, print every BDPRINTEVERY steps. + \item dafaults: BDSTEPS=1000, BDPRINTEVERY=1, BDPRINTLOG=false + \end{itemize} +% +\item {\it BRCRELAX} + \begin{itemize} + \item value: 1 float + \item parameter for extra force to keep segment lengths fixed when running Brownian Dynamics with a bead-rod model + \item {\color{red} Bead-rod BD are not debugged! do not use.} + \end{itemize} +% +\item {\it CONNECT} + \begin{itemize} + \item value: 4 integers + \item Connection point in a mesh of many chains + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it CONNECTMOD} + \begin{itemize} + \item value: 2 floats + \item something about connecting chains in a mesh... + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it CONNECTTYPE} + \begin{itemize} + \item value: 2 logicals + \item whether to connect together bead positions and/or orientations + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it CONSTMOD} + \begin{itemize} + \item value: 1 float + \item not currently used + \end{itemize} +% +\item {\it COUPLED} + \begin{itemize} + \item value: 1 logical + \item not currently used + \end{itemize} +% +\item {\it DELTSCL} + \begin{itemize} + \item value: 1 float + \item scaling constant used to set the timestep in Brownian Dynamics simulations + \item Ultimately, if the chain is designated as {\it SHEARABLE} then the timestep is $\delta t = \text{DELTSCL} * \text{min}(\zeta_{ub},\zeta_{rb})$, where the friction coefficients $\zeta_{ub},\zeta_{rb}$ are set using keyword {\it FRICT}. If the chain is not shearable, then $\delta t = \text{DELTSCL} * \zeta_{rb}$ + \end{itemize} +% +\item {\it DIAMONDLATTICE} + \begin{itemize} + \item value: 3 integers; 1 optional float + \item connect up a mesh of chains in a diamond lattice + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it DOLOCALMOVES} + \begin{itemize} + \item value: no values + \item When running a Monte Carlo calculation for a single chain, move individual beads rather than the default crank-shaft type moves + \end{itemize} +% +\item {\it DYNAMICREDISC} + \begin{itemize} + \item values: 2 floats (REDISCCUTFINE, REDISCCUTCOARSE), 1 integer (REDISCFACT), 1 optional integer (REDISCEDGE), 1 optional float (REDISCEQTIME) + \item When running a first-passage looping time calculation, rediscretize the chain dynamically depending on how close the two ends are + \item Switch to a finer discretization when the end-to-end distance is smaller than REDISCCUTFINE. Switch back to a coarse discretization when the end-to-end distance is larger than REDISCCUTCOARSE. + \item Rediscretization is by an integer factor of REDISCFACT. Each segment turns into REDISCFACT shorter segments + \item REDISCEDGE sets how many of the edge segments are rediscretized (make it bigger than half chain length to rediscretize the whole chain). By default, REDISCEDGE=1, so only the first and last segment are rediscretized. + \item REDISCEQTIME gives the total time for running a mini brownian dynamics simulation to equilibrate newly inserted beads. Default value is $\zeta_r\Delta^4/(3\pi/2)^4$, the timescale for bending equilibration of a single coarse segment. + \item + \end{itemize} +% +\item {\it EC} + \begin{itemize} + \item value: 1 float; default: 0 + \item The bend-shear coupling energetic parameter for the dssWLC + \item EC = $-\eta\epsilon_b$ using the notation in the Soft Matter paper + \end{itemize} +% +\item {\it EDGESEGS} + \begin{itemize} + \item value: 1 integer (N); 6 floats + \item set separate parameters for the first and last N segments + \item parameters, in order, are the ones usually set with the {\em LS, LP, GAM, EPAR, EPERP, EC} keywords + \end{itemize} +% +\item {\it EPAR} + \begin{itemize} + \item value: 1 float; default: 1D3 + \item Stretch modulus for the dssWLC energetics + \item EPAR = $\epsilon_\parallel$ using the notation in the Soft Matter paper + \end{itemize} +% +\item {\it EPERP} + \begin{itemize} + \item value: 1 float; default: 1D3 + \item Modified shear modulus for the dssWLC energetics + \item EPERP = $\hat{\epsilon}_\perp = \epsilon_\perp + \eta^2\epsilon_b$ using the notation in the Soft Matter paper + \end{itemize} +% +\item {\it EPAR} + \begin{itemize} + \item value: 1 float; default: 1D3 + \item Stretch modulus for the dssWLC energetics + \item EPAR = $\epsilon_\parallel$ using the notation in the Soft Matter paper + \end{itemize} +% +\item {\it FINITEXT} + \begin{itemize} + \item value: 1 optional float; default: 1D-3 + \item For Monte Carlo simulations, prevent individual segments from stretching beyond the contour length. + \item optional float is a scaling factor F where the stretch energy is a fraction (1-F) of the usual gaussian and a fraction F of a logarithmic term that prevents the overextension of the segment (as in the FENE model) + \item {\color{red} finite extension not tested for a while. Use at own risk.} + \end{itemize} +% +\item {\it FIXBEAD} + \begin{itemize} + \item value: 1 integer; 1 optional integer; 2 optional logical + \item first integer: which bead to hold fix + \item second integer: on which chain? (for multi-chain mesh runs); default=1 + \item logicals: fix position and/or orientation + \end{itemize} +% +\item {\it FIXBEAD1} + \begin{itemize} + \item value: no value + \item hold the first bead fixed, when running Brownian Dynamics + \item only set up to work {\bf without} Runge-Kutta + \end{itemize} +% +\item {\it FIXBEADMID} + \begin{itemize} + \item value: no value + \item hold the middle bead fixed, when running Brownian Dynamics + \item only set up to work {\bf without} Runge-Kutta + \end{itemize} +% +\item {\it FIXBOUNDARY} + \begin{itemize} + \item value: 2 or 4 integers + \item hold the boundary of a multi-chain mesh fixed + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it FIXBOUNDARY} + \begin{itemize} + \item no value + \item something to do with multichain mesh simulations... + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it FORCE} + \begin{itemize} + \item values: 2 integers; 3 optional floats + \item Add a force on a bead in a particular chain + \item first integer: which bead; second integer: which chain; floats: force vector + \item Used in Monte Carlo calculations only + \end{itemize} +% +\item {\it FRICT} + \begin{itemize} + \item values: 2 floats; one optional logical (FRICTPERLEN); default FRICTPERLEN is false + \item if FRICTPERLEN is true, then the position and u-vector friction per length of chain ($\zeta_r, \zeta_b$). For a chain with identical segment sizes, the 2 edge beads have half the friction coefficients of the other beads + \item if FRICTPERLEN is false, friction coefficients $\zeta_{rb}, \zeta_{ub}$ for the bead positions and orientation vectors explicitly + \item Used for Brownian Dynamics calculations only + \end{itemize} +% +\item {\it GAM} + \begin{itemize} + \item values: 1 float; default=1 + \item Fractional preferred segment extension $\gamma$ for the dssWLC energetics. + \end{itemize} +% +\item {\it GAUSSIANCHAIN} + \begin{itemize} + \item no values + \item For Brownian Dynamics calculations, treat the chain as a plain bead-spring chain with modulus EPAR/2/LS for each spring. + \item For EQUILDISTRIB calculations, treat it as a bead-spring chain with modulus EPAR/2/LS along $\vec{u}$ and modulus EPERP/2/LS perpendicular to $\vec{u}$. + \end{itemize} +% +\item {\it INITRANGE} + \begin{itemize} + \item values: 4 floats; defaults: 1D0 1D0 1D0 1D0 + \item For Monte Carlo simulations, initial step size ranges + \item angle range for type 1 moves; shift range for type 1 moves; angle range for type 2 moves; shift range for type 2 moves + \end{itemize} +% +\item {\it INTERPPARAMS} + \begin{itemize} + \item values: 1 logical; 1 string + \item if logical is true then at the start of the calculation, extract the energetic and dynamic parameters of the chain by interpolating from a data file. + \item string supplies the file containing data for the parameters (see \ref{sec:getparams}) + \end{itemize} +% +\item {\it LOGRTERM} + \begin{itemize} + \item no values + \item For an non-shearable chain, this includes the additional logarithmic terms to make it behave as a chain with $\epsilon_\perp\rightarrow \infty$ rather than just a plain stretchable chain + \item See appendix in Soft Matter paper for details + \item implemented in Brownian Dynamics and EQUILDISTRIB calculations only + \end{itemize} +% +\item {\it LOOPING} + \begin{itemize} + \item optional float LOOPRAD; optional string LOOPFILE + \item track the first-passage looping time in a Brownian Dynamics simulation + \item LOOPRAD is the radius such that chain is looped if ends approach within this distance + \item LOOPFILE is the filename in which to save the looping time of each chain + \item output columns in LOOPFILE: chain, step when first looped, loop time, end-to-end vector when first looped + \end{itemize} +% +\item {\it LP} + \begin{itemize} + \item 1 float; default 1 + \item bending modulus ($\epsilon_b$) for the dssWLC model + \end{itemize} +% +\item {\it LS} + \begin{itemize} + \item 1 float; default 1 + \item Segment length ($\Delta$) for the dssWLC model + \end{itemize} +% +\item {\it MCPRINTFREQ} + \begin{itemize} + \item 1 integer; 1 optional integer + \item first number is how often to print output to screen during MC simulation (in terms of number of steps) + \item second number is how often to output to the file set by {\em OUTFILE} + \item When doing EQUILDISTRIB action, second number is how often to print to screen (in terms of number of chains) + \item By default, second number is same as the first + \end{itemize} +% +\item {\it MCSTEPS} + \begin{itemize} + \item 1 integer; 2 optional integers; defaults: 1000,100,100 + \item First number is total number of MC steps to run if doing the MONTECARLO action + \item Second number is how often to update statistics, such as average end-to-end distance + \item Third number is the number of initialization steps in the Monte Carlo before you start calculating statistics or outputting to file + \item When running the EQUILDISTRIB action, the total number of sampled chains is given by the first parameter here + \end{itemize} +% +\item {\it NCHAIN} + \begin{itemize} + \item one integer + \item For Brownian Dynamics or Monte Carlo simulations, the number of chains to run in parallel + \item {\color{red} Warning: multi-chain Monte Carlo has not been tested in a long while. Use at own risk} + \end{itemize} +% +\item {\it NOBROWN} + \begin{itemize} + \item no values + \item Do not include the random Brownian forces in the Brownian Dynamics simulations + \end{itemize} +% +\item {\it NPT} + \begin{itemize} + \item 1 integer; 1 optional integer (MAXNPT) + \item Number of beads in each chain + \item If second integer provided, can also set the maximum allowed number of beads for the case of dynamic rediscretization. By default MAXNPT is the same as NPT + \item MAXNPT sets the sizes of all the different arrays in the chain object, so things will break massively if more beads than this ever show up + \end{itemize} +% +\item {\it OBSTACLE} + \begin{itemize} + \item 3 floats + \item radius, steric modulus, friction coefficient + \item sets up an obstacle to interact with the chain + \item {\color{red} Never fully implemented. Do not use!} + \end{itemize} +% +\item {\it OUTFILE} + \begin{itemize} + \item string; default *.out + \item General output file; * is replaced with suffix for the job + \item for EQUILDISTRIB action: end-to-end vector and first orientation vector for each chain + \item for BROWNDYN action: step, chain, energy, end-to-end vector, center of mass, first $\vec{u}$ vector; output frequency set by {\em BDPRINTFREQ} + \item for MONTECARLO action: step, type 1 move acceptance frequency, type 2 move acceptance frequency, average $R^2$, end-to-end vector, correlation between first and last $\vec{u}$, radius of gyration, correlation between end-to-end vector and first $\vec{u}$, some other stuff; output frequency set by {\em MCPRINTFREQ} + \end{itemize} +% +\item {\it OUTPUTBEADWEIGHT} + \begin{itemize} + \item 2 optional integers; defaults 500 50 + \item For MC simulations, when dumping snapshots, output an extra two columns which contain, for each mobile bead, the partition function integrated over $\vec{u}$ and integrated over $\vec{r}$ respectively + \item integers are number of integration points in each dimension; 2-dimensional integration over $\vec{u}$, 3-dimensional over $\vec{r}$ + \end{itemize} +% +\item {\it PARAMFROMSNAPSHOT} + \begin{itemize} + \item 1 optional logical; if not supplied then value set to true; if keyword is missing then default is false + \item if true, then energetic parameters LS, LP, GAM, EPAR, EPERP, EC will be extracted from the input snapshot file (set with {\em RESTART}) rather than using the ones in the parameter file + \end{itemize} +% +\item {\it REDISCRETIZE} + \begin{itemize} + \item 2 floats + \item dynamic rediscretization based on segment lengths + \item {\color{red} Not fully implemented. Do not use} + \end{itemize} +% +\item {\it REDISCRETIZE} + \begin{itemize} + \item 2 floats + \item dynamic rediscretization based on segment lengths + \item {\color{red} Not fully implemented. Do not use} + \end{itemize} +% +\item {\it RESTART} + \begin{itemize} + \item 1 optional string, 1 optional integer; defaults: start.out, 0 + \item restart calculation from a previously output chain snapshot + \item first parameter is the snapshot file + \item second parameters allows for skipping first few configurations in thefile + \item Will attempt to reach NCHAIN chains from the snapshot file. If there are not enough will start cycling through the configs in the file + \item For Monte Carlo simulations, the snapshot file contains a number on the first line that indicates what step to start from + \end{itemize} +% +\item {\it RNGSEED} + \begin{itemize} + \item 1 integer; default: false + \item seed for random number generator + \item value of 0 will seed with system time in milliseconds + \item value of -1 will use the last 5 characters in the suffix + \item value of -2 will use the last 4 charactes in the suffix and the millisecond time + \item otherwise: the seed is used directly (should be positive) + \end{itemize} +% +\item {\it RUNGEKUTTA} + \begin{itemize} + \item 1 integer; default: 4 + \item what order of runge-kutta method to use with Brownian Dynamics simulations + \item So far only 1st order (direct Euler's method) and 4th order Runge-Kutta are implemented; only 4-th order has been extensively tested + \end{itemize} +% +\item {\it SETSHEAR} + \begin{itemize} + \item 1 float + \item set a shear displasement for a chain mesh + \item \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it SHEARABLE} + \begin{itemize} + \item 1 logical; default true + \item set whether chain is shearable + \end{itemize} +% +\item {\it SNAPSHOTS} + \begin{itemize} + \item 1 optional integer, 1 optional string, 1 optional logical; defaults: 1, *.snap.out, false + \item Dump snapshots over the course of the calculation (for BROWNDYN, MONTECARLO, or EQUILDISTRIB actions) + \item integer: how often to dump snapshots; string: snapshot file (* is replaced with suffix); logical: append rather than rewriting the snapshot file + \end{itemize} +% +\item {\it STARTEQUIL} + \begin{itemize} + \item 1 optional integer (EQUILSAMPLETYPE), 1 optional float (STARTEQUILLP) + \item For Brownian Dynamics simulations only, start from a set of equilibrium chain configurations + \item EQUILSAMPLETYPE must be 1,2, or 3 and indicates how to generate the equilibrium sampling + \item EQUILSAMPLETYPE=1, use rejection sampling with a Lorentz envelope. Becomes very inefficient for short segments, high shear modulus + \item EQUILSAMPLETYPE=2, use rejection sampling with multivariate normal envelope; this is the preferred method for chains with short stiff segments; less efficient for highly flexible segments + \item EQUILSAMPLETYPE=3, use Monte Carlo sampling; really inefficient + \item If optional float is supplied, then sample from a bead-rod distribution with the given bend modulus (even if the actual chain for the BD simulations is a proper shearable chain) + \end{itemize} +% +\item {\it SQUARELATTICE} + \begin{itemize} + \item no values + \item set up a chain mesh with a square lattice + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it STARTCOLLAPSE} + \begin{itemize} + \item no values + \item start with a collapsed linear chain mesh + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it STERICS} + \begin{itemize} + \item 1 float, 1 optional integer, 1 optional float + \item for steric inter-bead interactions + \item First number is the steric radius, second is how many neighboring beads to skip in steric calculations, third is steric modulus + \item {\color{red} Steric calculations are not tested! do not use.} + \end{itemize} +% +\item {\it STRESSFILE} + \begin{itemize} + \item 1 string; default: *.stress.out + \item For Brownian Dynamics simulations, file in which to output shear stress correlation ($C_\text{shear}$) over time + \item How often to output is set by BDPRINTFREQ + \end{itemize} +% +\item {\it STRETCHABLE} + \begin{itemize} + \item 1 logical; default true + \item Chain is stretchable + \item Chains that are shearable but not stretchable are not implemented + \item Stretchable but not shearable is implemented + \end{itemize} +% +\item {\it TRACKDIST} + \begin{itemize} + \item four integers + \item For a multi-chain Monte Carlo calculation, track the average distance between two specific beads + \item numbers are: bead 1, chain 1, bead 2, chain 2 + \item {\color{red} Many-chain mesh calculations are not tested! do not use.} + \end{itemize} +% +\item {\it USEBDENERGY} + \begin{itemize} + \item no values + \item When running a Monte Carlo simulation, use the energy calculation as it was defined for Brownian Dynamics as opposed to just calculating the local change in energy at each step. + \item Makes for very inefficient simulations! + \end{itemize} +% +\item {\it USEPSEUDOFORCE} + \begin{itemize} + \item no values + \item Use pseudo-potential force when running bead-rod Brownian Dynamics simulations (SHEARABLE and STRETCHABLE set to false) + \end{itemize} +% +\item {\it VERBOSE} + \begin{itemize} + \item 1 logical; default: false + \item print extra output + \item not really implemented + \end{itemize} +% +% -------------------------- + +\end{itemize} + +\bibliographystyle{aip} +\bibliography{fiberModel} + +\end{document} diff --git a/BasicWLC/dssWLC/doc/README.toc b/BasicWLC/dssWLC/doc/README.toc new file mode 100644 index 00000000..46fc81d9 --- /dev/null +++ b/BasicWLC/dssWLC/doc/README.toc @@ -0,0 +1,16 @@ +\contentsline {section}{\numberline {1}Compilation Instructions}{2} +\contentsline {section}{\numberline {2}Usage Instructions}{2} +\contentsline {section}{\numberline {3}Examples for a Quick Start}{3} +\contentsline {subsection}{\numberline {3.1}Example 1: equilibrium sampling}{3} +\contentsline {subsection}{\numberline {3.2}Example 2: Brownian Dynamics}{3} +\contentsline {subsection}{\numberline {3.3}Example 3: Looping first-passage time}{4} +\contentsline {subsection}{\numberline {3.4}Example 4: Looping first-passage time, with dynamic rediscretization}{4} +\contentsline {subsection}{\numberline {3.5}Example 5: Monte Carlo}{4} +\contentsline {section}{\numberline {4}Auxiliary Scripts}{4} +\contentsline {subsection}{\numberline {4.1}Visualizing structures}{4} +\contentsline {section}{\numberline {5}Parameters for the dssWLC model}{5} +\contentsline {section}{\numberline {6}Description of Specific Calculations}{6} +\contentsline {subsection}{\numberline {6.1}EQUILDISTRIB action}{6} +\contentsline {subsection}{\numberline {6.2}BROWNDYN action}{7} +\contentsline {subsection}{\numberline {6.3}MONTECARLO action}{7} +\contentsline {section}{\numberline {7}Keyword Index}{7} diff --git a/BasicWLC/dssWLC/doc/test.aux b/BasicWLC/dssWLC/doc/test.aux new file mode 100644 index 00000000..f23e5468 --- /dev/null +++ b/BasicWLC/dssWLC/doc/test.aux @@ -0,0 +1 @@ +\relax diff --git a/BasicWLC/dssWLC/doc/test.log b/BasicWLC/dssWLC/doc/test.log new file mode 100644 index 00000000..f8721778 --- /dev/null +++ b/BasicWLC/dssWLC/doc/test.log @@ -0,0 +1,150 @@ +This is pdfTeX, Version 3.1415926-1.40.10 (TeX Live 2009/Debian) (format=pdflatex 2012.4.28) 5 JUN 2013 15:51 +entering extended mode + %&-line parsing enabled. +**test.tex +(./test.tex +LaTeX2e <2009/09/24> +Babel and hyphenation patterns for english, usenglishmax, dumylang, noh +yphenation, loaded. +(/usr/share/texmf-texlive/tex/latex/base/article.cls +Document Class: article 2007/10/19 v1.4h Standard LaTeX document class +(/usr/share/texmf-texlive/tex/latex/base/size12.clo +File: size12.clo 2007/10/19 v1.4h Standard LaTeX file (size option) +) +\c@part=\count79 +\c@section=\count80 +\c@subsection=\count81 +\c@subsubsection=\count82 +\c@paragraph=\count83 +\c@subparagraph=\count84 +\c@figure=\count85 +\c@table=\count86 +\abovecaptionskip=\skip41 +\belowcaptionskip=\skip42 +\bibindent=\dimen102 +) +(/usr/share/texmf-texlive/tex/latex/ltxmisc/url.sty +\Urlmuskip=\muskip10 +Package: url 2006/04/12 ver 3.3 Verb mode for urls, etc. +) +(/usr/share/texmf-texlive/tex/latex/setspace/setspace.sty +Package: setspace 2000/12/01 6.7 Contributed and Supported LaTeX2e package + +Package: `setspace' 6.7 <2000/12/01> +) (/usr/share/texmf-texlive/tex/latex/amsmath/amsmath.sty +Package: amsmath 2000/07/18 v2.13 AMS math features +\@mathmargin=\skip43 + +For additional information on amsmath, use the `?' option. +(/usr/share/texmf-texlive/tex/latex/amsmath/amstext.sty +Package: amstext 2000/06/29 v2.01 + +(/usr/share/texmf-texlive/tex/latex/amsmath/amsgen.sty +File: amsgen.sty 1999/11/30 v2.0 +\@emptytoks=\toks14 +\ex@=\dimen103 +)) +(/usr/share/texmf-texlive/tex/latex/amsmath/amsbsy.sty +Package: amsbsy 1999/11/29 v1.2d +\pmbraise@=\dimen104 +) +(/usr/share/texmf-texlive/tex/latex/amsmath/amsopn.sty +Package: amsopn 1999/12/14 v2.01 operator names +) +\inf@bad=\count87 +LaTeX Info: Redefining \frac on input line 211. +\uproot@=\count88 +\leftroot@=\count89 +LaTeX Info: Redefining \overline on input line 307. +\classnum@=\count90 +\DOTSCASE@=\count91 +LaTeX Info: Redefining \ldots on input line 379. +LaTeX Info: Redefining \dots on input line 382. +LaTeX Info: Redefining \cdots on input line 467. +\Mathstrutbox@=\box26 +\strutbox@=\box27 +\big@size=\dimen105 +LaTeX Font Info: Redeclaring font encoding OML on input line 567. +LaTeX Font Info: Redeclaring font encoding OMS on input line 568. +\macc@depth=\count92 +\c@MaxMatrixCols=\count93 +\dotsspace@=\muskip11 +\c@parentequation=\count94 +\dspbrk@lvl=\count95 +\tag@help=\toks15 +\row@=\count96 +\column@=\count97 +\maxfields@=\count98 +\andhelp@=\toks16 +\eqnshift@=\dimen106 +\alignsep@=\dimen107 +\tagshift@=\dimen108 +\tagwidth@=\dimen109 +\totwidth@=\dimen110 +\lineht@=\dimen111 +\@envbody=\toks17 +\multlinegap=\skip44 +\multlinetaggap=\skip45 +\mathdisplay@stack=\toks18 +LaTeX Info: Redefining \[ on input line 2666. +LaTeX Info: Redefining \] on input line 2667. +) +(/usr/share/texmf-texlive/tex/latex/graphics/color.sty +Package: color 2005/11/14 v1.0j Standard LaTeX Color (DPC) + +(/etc/texmf/tex/latex/config/color.cfg +File: color.cfg 2007/01/18 v1.5 color configuration of teTeX/TeXLive +) +Package color Info: Driver file: pdftex.def on input line 130. + +(/usr/share/texmf-texlive/tex/latex/pdftex-def/pdftex.def +File: pdftex.def 2010/03/12 v0.04p Graphics/color for pdfTeX +\Gread@gobject=\count99 +)) (./test.aux) +\openout1 = `test.aux'. + +LaTeX Font Info: Checking defaults for OML/cmm/m/it on input line 5. +LaTeX Font Info: ... okay on input line 5. +LaTeX Font Info: Checking defaults for T1/cmr/m/n on input line 5. +LaTeX Font Info: ... okay on input line 5. +LaTeX Font Info: Checking defaults for OT1/cmr/m/n on input line 5. +LaTeX Font Info: ... okay on input line 5. +LaTeX Font Info: Checking defaults for OMS/cmsy/m/n on input line 5. +LaTeX Font Info: ... okay on input line 5. +LaTeX Font Info: Checking defaults for OMX/cmex/m/n on input line 5. +LaTeX Font Info: ... okay on input line 5. +LaTeX Font Info: Checking defaults for U/cmr/m/n on input line 5. +LaTeX Font Info: ... okay on input line 5. + +(/usr/share/texmf-texlive/tex/context/base/supp-pdf.mkii +[Loading MPS to PDF converter (version 2006.09.02).] +\scratchcounter=\count100 +\scratchdimen=\dimen112 +\scratchbox=\box28 +\nofMPsegments=\count101 +\nofMParguments=\count102 +\everyMPshowfont=\toks19 +\MPscratchCnt=\count103 +\MPscratchDim=\dimen113 +\MPnumerator=\count104 +\everyMPtoPDFconversion=\toks20 +) [1 + +{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] (./test.aux) ) +Here is how much of TeX's memory you used: + 1447 strings out of 495061 + 17244 string characters out of 1182621 + 68733 words of memory out of 3000000 + 4665 multiletter control sequences out of 15000+50000 + 5601 words of font info for 21 fonts, out of 3000000 for 9000 + 28 hyphenation exceptions out of 8191 + 27i,6n,20p,218b,191s stack positions out of 5000i,500n,10000p,200000b,50000s + +Output written on test.pdf (1 page, 25391 bytes). +PDF statistics: + 14 PDF objects out of 1000 (max. 8388607) + 0 named destinations out of 1000 (max. 500000) + 1 words of extra memory for PDF output out of 10000 (max. 10000000) + diff --git a/BasicWLC/dssWLC/doc/test.pdf b/BasicWLC/dssWLC/doc/test.pdf new file mode 100644 index 00000000..dccd058a Binary files /dev/null and b/BasicWLC/dssWLC/doc/test.pdf differ diff --git a/BasicWLC/dssWLC/doc/test.tex b/BasicWLC/dssWLC/doc/test.tex new file mode 100644 index 00000000..c517c5f3 --- /dev/null +++ b/BasicWLC/dssWLC/doc/test.tex @@ -0,0 +1,15 @@ +\documentclass[12pt]{article} +\usepackage{url,setspace,amsmath} +\usepackage{color} + +\begin{document} +\title{foobar} +\author{E.~F.~Koslover, A.~J.~Spakowitz} +\date{Last updated \today} +\maketitle + +This code can be used to run {\color{red} Brownian Dynamics} or Monte Carlo simulations of the dssWLC model. + + + +\end{document} diff --git a/BasicWLC/dssWLC/examples/dssWLCparams.txt b/BasicWLC/dssWLC/examples/dssWLCparams.txt new file mode 100644 index 00000000..b857acb0 --- /dev/null +++ b/BasicWLC/dssWLC/examples/dssWLCparams.txt @@ -0,0 +1,60 @@ +0.01 1.3893 0.99891 1.2604e+05 2.3725e+05 259.11 2.4113e-06 0.00021121 +0.011721 1.4546 0.99866 75387 1.7732e+05 237.2 3.2206e-06 0.00024121 +0.013738 1.5065 0.99839 48282 1.3227e+05 213.08 4.3181e-06 0.00027605 +0.016103 1.517 0.99785 33576 74999 161.89 6.226e-06 0.0004158 +0.018874 1.5405 0.99741 23265 53018 138.51 8.5491e-06 0.00050227 +0.022122 1.5481 0.99677 16573 34412 112.43 1.2038e-05 0.00066107 +0.025929 1.5649 0.99624 11822 26073 99.205 1.6292e-05 0.00074517 +0.030392 1.568 0.99546 8600 17961 82.81 2.2633e-05 0.00092434 +0.035622 1.5848 0.99459 6142.9 12924 71.288 3.0994e-05 0.0010979 +0.041753 1.5832 0.99317 4444.8 8078.5 56.614 4.4159e-05 0.0015028 +0.048939 1.5818 0.9923 3342.2 6387 50.61 5.8957e-05 0.0016245 +0.057362 1.5742 0.99074 2502.5 4388.2 42.047 8.2134e-05 0.0020237 +0.067234 1.5765 0.98907 1854.7 3168.7 36.085 0.00011275 0.0023991 +0.078805 1.5733 0.98675 1383.9 2152.3 29.964 0.0001572 0.0030276 +0.092367 1.5734 0.98426 1036 1528 25.531 0.00021616 0.003657 +0.10826 1.5729 0.98127 779.72 1081.5 21.753 0.0002966 0.0044347 +0.1269 1.5746 0.97806 589.76 793.29 18.939 0.00040114 0.0051922 +0.14874 1.5726 0.97366 449.26 548.77 16.003 0.00055133 0.0064618 +0.17433 1.5727 0.96886 344.63 392.95 13.816 0.00075187 0.0077757 +0.20434 1.5722 0.963 266.69 277.82 11.881 0.0010247 0.0094976 +0.2395 1.5716 0.95609 208.6 196.27 10.244 0.0013892 0.011636 +0.28072 1.5707 0.94807 165.31 139.31 8.8783 0.0018677 0.014224 +0.32903 1.5677 0.93875 133.36 98.947 7.7017 0.0025008 0.017427 +0.38566 1.5622 0.92778 109.54 70.004 6.6581 0.003371 0.021516 +0.45204 1.5539 0.91541 91.402 50.234 5.7717 0.0045193 0.026276 +0.52983 1.5417 0.90171 77.102 36.91 5.0121 0.006012 0.031445 +0.62102 1.5252 0.8863 65.188 27.777 4.3277 0.007935 0.036899 +0.7279 1.5055 0.87001 54.418 22.103 3.7488 0.010551 0.041058 +0.85317 1.4842 0.85273 44.35 18.722 3.2384 0.013947 0.043049 +1 1.4646 0.83456 35.107 17.067 2.777 0.01824 0.042062 +1.1 1.4614 0.81725 28.894 14.733 2.5829 0.021131 0.046192 +1.2 1.4574 0.8004 24.338 12.987 2.4284 0.023932 0.05008 +1.3 1.4527 0.784 20.921 11.625 2.3012 0.026973 0.053826 +1.4 1.4475 0.76795 18.303 10.513 2.1923 0.029911 0.057605 +1.5 1.4419 0.75181 16.268 9.5129 2.0895 0.032785 0.061993 +1.6 1.4359 0.73685 14.626 8.7798 2.0115 0.035564 0.065555 +1.7 1.4296 0.72254 13.289 8.1802 1.9459 0.038584 0.06887 +1.8 1.4231 0.70851 12.192 7.6397 1.8848 0.041468 0.072433 +1.9 1.4164 0.69505 11.274 7.182 1.8318 0.044228 0.075846 +2 1.4096 0.68218 10.497 6.7923 1.7857 0.046899 0.079091 +2.1 1.4026 0.6698 9.8323 6.451 1.7446 0.049515 0.082269 +2.2 1.3956 0.65784 9.2594 6.1463 1.7072 0.052135 0.085446 +2.3 1.3885 0.64653 8.7584 5.8914 1.6757 0.054898 0.088278 +2.4 1.3813 0.63527 8.3235 5.6333 1.6428 0.057573 0.09164 +2.5 1.3741 0.62487 7.9343 5.4357 1.6179 0.060118 0.094231 +2.6 1.3668 0.61464 7.5907 5.2407 1.5929 0.062599 0.097132 +2.7 1.3596 0.60485 7.2828 5.0681 1.5706 0.065009 0.099877 +2.8 1.3523 0.59536 7.0066 4.907 1.5496 0.067367 0.10267 +2.9 1.3451 0.58635 6.7559 4.7683 1.5316 0.069675 0.10517 +3 1.3379 0.57756 6.5292 4.6351 1.5142 0.071953 0.10779 +3.1 1.3306 0.5692 6.3217 4.5195 1.4992 0.074199 0.11015 +3.2 1.3234 0.56102 6.1328 4.406 1.4843 0.076506 0.11267 +3.3 1.3163 0.55317 5.9589 4.3044 1.4711 0.078846 0.11503 +3.4 1.3091 0.54549 5.7994 4.2044 1.4578 0.08112 0.11755 +3.5 1.302 0.53834 5.6505 4.1258 1.4481 0.083326 0.11948 +3.6 1.2949 0.53106 5.5145 4.0338 1.4357 0.085487 0.12209 +3.7 1.2879 0.52432 5.3866 3.9633 1.427 0.087592 0.12403 +3.8 1.2809 0.51755 5.2686 3.8851 1.4167 0.089657 0.12644 +3.9 1.274 0.51124 5.1574 3.8235 1.4093 0.091681 0.12829 +4 1.2671 0.50516 5.0532 3.7671 1.4026 0.093672 0.13003 diff --git a/BasicWLC/dssWLC/examples/param.ex.browndyn b/BasicWLC/dssWLC/examples/param.ex.browndyn new file mode 100644 index 00000000..c9bafbd3 --- /dev/null +++ b/BasicWLC/dssWLC/examples/param.ex.browndyn @@ -0,0 +1,34 @@ +# --------------------- +# Example parameter file for running a brownian dynamics simulation +# while keeping track of shear stress correlation +# ---------------------- +# Run Brownian Dynamics +ACTION browndyn +# using 4-th order runge-kutta +RUNGEKUTTA 4 +# Run 2000 chains in parallel +NCHAIN 2000 +# run for 10000 steps; print output on a logarithmic schedule +BDSTEPS 10000 0.05 T +# seed random number generator from system time +RNGSEED 0 +# segment length 1 +LS 1 +# 10 segments (so 11 beads) +NPT 11 +# chain is stretchable, shearable, and has bend-shear coupling +STRETCHABLE T +SHEARABLE T +COUPLED T +# chain energetic parameters +LP 1.4645 +GAM 0.83485 +EPAR 35.116 +EPERP 28.509 +EC -4.0746 +# position and orientation friction coefficients for each bead +FRICT 0.9091 0.017D0 +# timestep as a multiple of friction +DELTSCL 4e-2 +# start with chains sampled from an equilibrium distribution +STARTEQUIL 2 diff --git a/BasicWLC/dssWLC/examples/param.ex.equildistrib b/BasicWLC/dssWLC/examples/param.ex.equildistrib new file mode 100644 index 00000000..eb97341b --- /dev/null +++ b/BasicWLC/dssWLC/examples/param.ex.equildistrib @@ -0,0 +1,32 @@ +#------------ +# Example file for generating a bunch of chain configurations +# from equilibrium distribution +# ------------- +ACTION EQUILDISTRIB +# initialize random generator from system time +RNGSEED 0 +# chain is stretchable, shearable, and has bend-shear coupling +STRETCHABLE T +SHEARABLE T +COUPLED T +# 13 beads in each chain +NPT 13 +# set separate parameters for the first 2 and last 2 segments +# which will have a segment length of 0.1 +EDGESEGS 2 0.1 1.5690 0.9833 912.3723 2261.5 -37.789 +# parameters for all other segments, with segment length 0.2 +LS 0.2 +LP 1.5727 +GAM 0.9637 +EPAR 275.4397 +EPERP 518.3996 +EC -19.0002 +# set the sampling algorithm (rejection sampling with multivariate normal) +STARTEQUIL 2 +# sample 10000 chains total +MCSTEPS 10000 1 1 +# print output every 500 chains +MCPRINTFREQ 500 +# save a snapshot of every 1000-th chain configuration +SNAPSHOTS 1000 *.snap.out F +# \ No newline at end of file diff --git a/BasicWLC/dssWLC/examples/param.ex.loop b/BasicWLC/dssWLC/examples/param.ex.loop new file mode 100644 index 00000000..4fde2a75 --- /dev/null +++ b/BasicWLC/dssWLC/examples/param.ex.loop @@ -0,0 +1,40 @@ +#------------ +# Example file for running a Brownian Dynamics +# simulation of first-passage looping time +# ------------- +ACTION browndyn +# use 4-th order Runge-Kutta for the Brownian DYnamics +RUNGEKUTTA 4 +# run 1000 chains in parallel +NCHAIN 1000 +# run for a maximum of 1000000 степс +BDSTEPS 1е6 0.5 T +# seed random number generator from system time +RNGSEED 0 +# 13 beads in each chain +NPT 13 +# set separate parameters for the first 2 and last 2 segments +# which will have a segment length of 0.1 +EDGESEGS 2 0.1 1.5690 0.9833 912.3723 2261.5 -37.789 +# parameters for all other segments, with segment length 0.2 +LS 0.2 +LP 1.5727 +GAM 0.9637 +EPAR 275.4397 +EPERP 518.3996 +EC -19.0002 +# chain is stretchable, shearable, and has bend-shear coupling +STRETCHABLE T +SHEARABLE T +COUPLED T +# friction coefficients per unit length +FRICT 1D0 9.8e-4 T +# timestep as a multiple of friction +DELTSCL 3.9e-3 +# start from an equilibrium distribution +STARTEQUIL 2 +# track first-passage looping events +# with a looping radius of 0.2 +# save looping times for each chain in *.loop.out file as it loops +LOOPING 0.2 *.loop.out +# \ No newline at end of file diff --git a/BasicWLC/dssWLC/examples/param.ex.montecarlo b/BasicWLC/dssWLC/examples/param.ex.montecarlo new file mode 100644 index 00000000..968698f3 --- /dev/null +++ b/BasicWLC/dssWLC/examples/param.ex.montecarlo @@ -0,0 +1,31 @@ +# ----------------- +# Run a monte-carlo simulation to sample chain configurations +# ----------------- +ACTION montecarlo +# seed random number generator off system time +RNGSEED 0 +# segment length 1 +LS 1 +# 4 segments (so 5 beads) +NPT 5 +# chain is stretchable, shearable, and has bend-shear coupling +STRETCHABLE T +SHEARABLE T +COUPLED T +# chain energetic parameters +LP 1.4645 +GAM 0.83485 +EPAR 35.116 +EPERP 28.509 +EC -4.0746 +# Run 10^8 monte carlo steps, taking average statistics every 1000 steps +# first 500000 steps are for initialization only +MCSTEPS 100000000 1000 500000 +# print output to screen every 100000 steps, to file every 1000 steps +MCPRINTFREQ 100000 1000 +# adjust step size every 50000 steps +# attempts to keep an acceptance ratio of 50% +/- 10% +# adjusts by a factor of 2 each time +ADJUSTRANGE 50000 0.5 0.1 2 +# initial step size +INITRANGE 1 1D-1 1 1D-1 diff --git a/BasicWLC/dssWLC/examples/param.ex.redisc b/BasicWLC/dssWLC/examples/param.ex.redisc new file mode 100644 index 00000000..ce11d144 --- /dev/null +++ b/BasicWLC/dssWLC/examples/param.ex.redisc @@ -0,0 +1,33 @@ +# --------------- +# Do a first-passage looping calculation +# with dynamic rediscretization whenever the chain ends come close together +# ---------------- +ACTION browndyn +RUNGEKUTTA 4 +NCHAIN 1000 +BDSTEPS 10000000 0.5 T +RNGSEED 0 +LS 0.2 +NPT 11 50 +STRETCHABLE T +SHEARABLE T +COUPLED T +LP 1.5727 +GAM 0.9637 +EPAR 275.4397 +EPERP 518.3996 +EC -19.0002 +FRICT 1D0 2.5e-4 T +DELTSCL 9.3e-3 +STARTEQUIL 2 +LOOPING 0.2 *.loop.out +# interpolate parameters, including starting parameters from the following file +INTERPPARAMS T dssWLCparams.txt +# rediscretize to finer chain when end-to-end distance goes below 0.4 +# coarsen chain when end-to-end distance is above 0.5 +# rediscretize by a factor of 4 +# rediscretize 5 edge segments from each side (so entire chain) +# do brownian dynamics for time 1D-5 to equilibrate new beads +# each time chain is rediscretized +DYNAMICREDISC 0.4D0 0.5D0 4 5 1D-5 +# \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/Wigner3j.m b/BasicWLC/dssWLC/getparams/Wigner3j.m new file mode 100644 index 00000000..0f0141aa --- /dev/null +++ b/BasicWLC/dssWLC/getparams/Wigner3j.m @@ -0,0 +1,97 @@ + +% Wigner3j.m by David Terr, Raytheon, 6-17-04 + +% Compute the Wigner 3j symbol using the Racah formula [1]. +% EFK 20130326: modified to use pretabulated factorials for speed + +function wigner = Wigner3j(j1,j2,j3,m1,m2,m3,factsave) + +% error checking +if ( 2*j1 ~= floor(2*j1) || 2*j2 ~= floor(2*j2) || 2*j3 ~= floor(2*j3) ... + || 2*m1 ~= floor(2*m1) || 2*m2 ~= floor(2*m2) || 2*m3 ~= floor(2*m3) ) + error('All arguments must be integers or half-integers.'); + return; +end + +if ( j1 - m1 ~= floor ( j1 - m1 ) ) + error('2*j1 and 2*m1 must have the same parity'); + return; +end + +if ( j2 - m2 ~= floor ( j2 - m2 ) ) + error('2*j2 and 2*m2 must have the same parity'); + return; +end + +if ( j3 - m3 ~= floor ( j3 - m3 ) ) + error('2*j3 and 2*m3 must have the same parity'); + return; +end + +if j3 > j1 + j2 || j3 < abs(j1 - j2) + error('j3 is out of bounds.'); + return; +end + +if abs(m1) > j1 + error('m1 is out of bounds.'); + return; +end + +if abs(m2) > j2 + error('m2 is out of bounds.'); + return; +end + +if abs(m3) > j3 + error('m3 is out of bounds.'); + return; +end + +if m1+m2+m3 ~= 0 + error('m1+m2+m3 is not 0') + return; +end + +t1 = j2 - m1 - j3; +t2 = j1 + m2 - j3; +t3 = j1 + j2 - j3; +t4 = j1 - m1; +t5 = j2 + m2; + +tmin = max( 0, max( t1, t2 ) ); +tmax = min( t3, min( t4, t5 ) ); + +wigner = 0; +if nargin > 6 + % use pretabulated factorials + for t = tmin:tmax + wigner = wigner + (-1)^t / ( fact(t) * fact(t-t1) * fact(t-t2) ... + * fact(t3-t) * fact(t4-t) * fact(t5-t) ); + end + + wigner = wigner * (-1)^(j1-j2-m3) ... + * sqrt( fact(j1+j2-j3) * fact(j1-j2+j3) * fact(-j1+j2+j3) / fact(j1+j2+j3+1)... + * fact(j1+m1) * fact(j1-m1) * fact(j2+m2) * fact(j2-m2) * fact(j3+m3) * fact(j3-m3) ); +else + % calculate factorials from scratch + for t = tmin:tmax + wigner = wigner + (-1)^t / ( factorial(t) * factorial(t-t1) * factorial(t-t2) ... + * factorial(t3-t) * factorial(t4-t) * factorial(t5-t) ); + end + + wigner = wigner * (-1)^(j1-j2-m3) ... + * sqrt( factorial(j1+j2-j3) * factorial(j1-j2+j3) * factorial(-j1+j2+j3) / factorial(j1+j2+j3+1)... + * factorial(j1+m1) * factorial(j1-m1) * factorial(j2+m2) * factorial(j2-m2) * factorial(j3+m3) * factorial(j3-m3) ); +end + +% function for including 0 index in pretabulated factorials + function res = fact(x) + if (x==0) + res = 1; + else + res = factsave(x); + end + end +end +% Reference: Wigner 3j-Symbol entry of Eric Weinstein's Mathworld: http://mathworld.wolfram.com/Wigner3j-Symbol.html \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/cofactor.m b/BasicWLC/dssWLC/getparams/cofactor.m new file mode 100644 index 00000000..994b4ce6 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/cofactor.m @@ -0,0 +1,18 @@ +function C = cofactor(A,i,j) +%COFACTOR Cofactors and the cofactor matrix. +% COFACTOR(A,i,j) returns the cofactor of row i, column j. +% COFACTOR(A) returns the matrix C of cofactors. +if nargin == 3 + % Remove row i and column j to produce the minor. + M = A; + M(i,:) = []; + M(:,j) = []; + C = (-1)^(i+j)*det(M); +else + [n,n] = size(A); + for i = 1:n + for j = 1:n + C(i,j) = cofactor(A,i,j); + end + end +end diff --git a/BasicWLC/dssWLC/getparams/dssWLCcalcparams.m b/BasicWLC/dssWLC/getparams/dssWLCcalcparams.m new file mode 100644 index 00000000..ef0d5113 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLCcalcparams.m @@ -0,0 +1,119 @@ +function [eb,gam,epar,eperp,eta,alpha,zetau,delt] = dssWLCcalcparams(del,Nseg,varargin) +% calculate the appropriate parameters for a dssWLC simulation +% for discretizing a continuous WLC with persistence length lp=1 +% usage: +% dssWLCcalcparams(del,Nseg,'interpfile',filename,'alpha',alpha,'LMAX',LMAX +% ,'YcoupleFile',filename) +% +% Required arguments: +% del = segment length +% Nseg = total number of segments in the chain +% +% optional arguments: +% +% interpfile: if supplied then interpolate the energetic parameters from the +% the given space-delimited file. Otherwise, recalculate from scratch +% +% alpha: if single value is supplied then calculate the energetic +% parameters for the given alpha value. If pair of values is supplied then +% this gives the range of possible alpha values, and the code optimizes +% over the possible alphas within this range to get the best length scale +% of accuracy. Default: [1e-5,1.5] +% +% LMAX: if optimizing over alpha values, the maximum l-index of the +% matrices used to calculate structure factors; default=10 +% +% YcoupleFile: if optimizing over alpha values, the file containing saved +% coupling coefficients for spherical harmonics. Default: YcoupleSave.mat +% if this file does not exist it will be created as the coupling +% coefficients are calculated. + +p = inputParser; +addRequired(p,'del',@isnumeric); +addRequired(p,'Nseg',@(x) isnumeric(x) && x>0); +addParamValue(p,'interpfile',NaN,@ischar); +addParamValue(p,'alpha',[1e-5,2],@isnumeric); +addParamValue(p,'LMAX',10,@(x) (isnumeric(x) && x <= 20 && x>=0)); +addParamValue(p,'YcoupleFile','YcoupleSave.mat',@ischar); +parse(p,del,Nseg,varargin{:}); + +if any(ismember('interpfile',p.UsingDefaults)) + % calculate parameter files directly + if (any(ismember('alpha',p.UsingDefaults)) || length(p.Results.alpha)>1) + disp('Calculating dssWLC energetic parameters, optimizing alpha for lowest length scale of accuracy') + + % load in the spherical harmonic coupling coefficients + if (exist(p.Results.YcoupleFile,'file')) + disp(sprintf('Loading Y coupling coefficients from %s', p.Results.YcoupleFile)); + load(p.Results.YcoupleFile,'Ycouple'); + else + % recalculate & save if file does not exist + disp(sprintf('Recalculating spherical harmonic coupling coefficients. Will save in %s and avoid recalculating in future.',p.Results.YcoupleFile)) + LMAX = 20; + Ycouple = getYcouple(LMAX,p.Results.YcoupleFile); + end + + nk = 100; Ltot = 1000; LMAX = p.Results.LMAX; + % cutoff in structure factor error for calculating length scale + cutoff = 1e-4; + + klist = logspace(log10(1/del/10),log10(1/del*2),nk); + + % get plain wlc structure factor + display('Calculating plain WLC structure factor') + nseg = Ltot/del; + I = eye(LMAX+1); + for kc = 1:nk + Mplain = shearWLCpropagator(klist(kc),del,1,1,0,0,0,LMAX); + Mtot = ((nseg+1)*I+Mplain^(nseg+2) - Mplain*(nseg+2))*inv(Mplain-I)^2; + Splain(kc) = 2*Mtot(1,1)/(nseg+1)^2; + end + + options = optimset('Display','iter','TolX',1e-4); + alpharange = p.Results.alpha; + display('Optimizing over alpha') + [alpha,lscale] = fminbnd(@(alpha) dssWLClengthScale(del,alpha,Ltot,klist,Splain,Ycouple,cutoff,LMAX),... + alpharange(1),alpharange(2),options); + [eb,gam,epari,eperpi,eta,err,plen] = dssWLCminLpParams(del,alpha); + epar = 1/epari; + eperp = 1/eperpi; + else + alpha = p.Results.alpha + disp(sprintf('Calculating energetic parameters using alpha=%f',alpha)) + [eb,gam,epari,eperpi,eta,err,plen] = dssWLCminLpParams(del,alpha); + epar = 1/epari; + eperp = 1/eperpi; + end +else + % interpolate parameter values from the data file + disp(sprintf('Interpolating energetic parameters from tabulated file: %s',p.Results.interpfile)) + data = dlmread('dssWLCparams.txt'); + params = interp1(data(:,1),data(:,2:end),del); + eb = params(1); gam = params(2); epar = params(3); eperp = params(4); eta = params(5); + alpha = eta^2*eb/eperp; +end + +disp(sprintf('Energetic parameters (eb,g,epar,eperp,eta): %f %f %f %f %f',eb,gam,epar,eperp,eta)) +disp('Calculating dynamic parameters: zeta_u and del_t') + +% find appropriate xiu value +eperph = eperp + eta^2*eb; +xir = 1; +xiulist = logspace(-7,1,50); +L=del; +pval = 1; +tfast = zeros(size(xiulist)); + +for uc = 1:length(xiulist) + xiu = xiulist(uc); + [evals,evecs,pareval] = ssWLCdynamics(eb,gam,epar,eperph,eta,L,xir,xiu,50); + tfast(uc) = -1/evals(end); +end + +dt = diff(log10(tfast)); +lxiu = interp1(dt,log10(xiulist(1:end-1)),(dt(1)+dt(end))/2); +zetau = 10^lxiu*del/(1+1/Nseg); + +% get the appropriate delt +delt = 0.5/(eperp*gam^2*del)*zetau; + diff --git a/BasicWLC/dssWLC/getparams/dssWLCgetParams.m b/BasicWLC/dssWLC/getparams/dssWLCgetParams.m new file mode 100644 index 00000000..399812e0 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLCgetParams.m @@ -0,0 +1,213 @@ +function [g,epari,eperpi,eta]= dssWLCgetParams(del,eb,alpha,R2l,R2c,R4l) +% ------- +% calculate g,epari,eperpi for a dssWLC model +% where del, alpha, eb are fixed and we want to fit the moments R2l, R2c, R4l +% alpha = eta^2*eb/eperp + +% solve for eb to match lpeff (using xi_1) +% solve for eperpih = 1/(eperp-hat) as a function of g to fit R2c +% solve for epari as a function of g to fit R2l +% solve for g to fit R4l +% ------- + +if max(abs(imag([del,eb,alpha])))>0 || eb<0 || del <0 || alpha<0 + moms = 0; M1=0; epari = 0; eperpi=0; R2ctmp = 0; g =0; + return +end + +x = alpha/(1+alpha)*eb; +M0=1; +%% +LMAX=4; +[xivals,tmp] = expandFsph(del,eb,alpha,LMAX); + +M1 = xivals(2); M2 = xivals(3); M3 = xivals(4); M4 = xivals(5); + +%[M1 M2 M3 M4] +%return +% -------------- +%% coupling coefficients +% go up one with D10 +alj = @(l,j) sqrt(3*(l-j)*(l+j)/((2*l+1)*(2*l-1))); +% go up one in both l and j with D11 +ahlj = @(l,j) sqrt(3/2)*sqrt((l+j)*(l+j-1)/((2*l-1)*(2*l+1))); +% stay in place with D20 +blj = @(l,j) sqrt(5)*(l^2+l-3*j^2)/((2*l-1)*(2*l+3)); +% go up 2 with D20, for j=0 +bhlj = @(l,j) 3*sqrt(5)/2/(2*l-1)*sqrt((j-l)*(j-l+1)*(j+l)*(j+l-1)/((2*l+1)*(2*l-3))); +% go up one with D30 +clj = @(l,j) -sqrt(7)*3/2*(1+5*j^2-l^2)/((2*l-3)*(2*l+3))*alj(l,j)/sqrt(3); +% stay put with D40 +dlj = @(l,j) 9/4*(35*j^4 + 3*(l-1)*l*(l+1)*(l+2) - 5*j^2*(6*l^2+6*l-5))... + /((2*l-3)*(2*l-1)*(2*l+3)*(2*l+5)); +dhlj = @(l,j) 15/2*(l^2-l-7*j^2-2)/((2*l-5)*(2*l-1)*(2*l+3))*sqrt((j-l)*(j-l+1)*(j+l)*(j+l-1)/((2*l+1)*(2*l-3))); + +%% get ec/eperp as function of gamma +A = 2/(M1-1)^2*i*del/sqrt(3); +B = -i/3/sqrt(3)*(2 + 2*sqrt(5)*M2*blj(1,1)); +C = i*del/sqrt(3)*M1; +Z1 = R2c/A/B; Z2 = -C/B; + +%% get epari as a function of gamma + +%s00 = M0*( - 2/3*(del/2*epari + del*eperpi)) ... +% +2*ec^2/9*eperpi^2*sqrt(5)*M2*bhlj(2,0)*ahlj(2,0)*ahlj(1,1); + + +A = (M1-1)*R2c/del; +B = -1/del*(-2/9*ahlj(1,1)^2+2*sqrt(5)/9*M2*bhlj(2,0)*ahlj(2,0)*ahlj(1,1)-2*del/3/x); +C = del*alj(1,0)/3; +D = 1/3; +Z3 = -B*Z1^2/D; +Z4 = (-B*Z2^2-C)/D; +Z5 = (R2l - A - 2*B*Z1*Z2)/D; + +%E = Z1/g + Z2*g; +%eperpi = E^2/x; +%epari = Z3/g^2 + Z4*g^2 + Z5; + +%% to fit R4l, go through each of the individual steps and calculate +% coefficients of: 1/g^4, 1/g^3,1/g^2, 1/g, 1, g, g^2, g^3, g^4 +Eg = [0,0,0,Z1,0,Z2,0,0,0]; %E +Eg2 = [0,0,Z1^2,0,2*Z1*Z2,0,Z2^2,0,0]; %E^2 +Eg3 = [0,Z1^3,0,3*Z1^2*Z2,0,3*Z1*Z2^2,0,Z2^3,0];%E^3 +Eg4 = [Z1^4,0,4*Z1^3*Z2,0,6*Z1^2*Z2^2,0,4*Z1*Z2^3,0,Z2^4];%E^4 +Eparg = [0,0,Z3,0,Z5,0,Z4,0,0]; %epari +EpargG = [0,0,0,Z3,0,Z5,0,Z4,0]; %epari*g +EpargG2 = [0,0,0,0,Z3,0,Z5,0,Z4]; %epari*g^2 +EpargEg = [0,Z1*Z3, 0,Z2*Z3+Z1*Z5,0,Z2*Z5+Z1*Z4,0,Z2*Z4,0]; %E*epari +EpargEg2 = [Z1^2*Z3,0,Z1^2*Z5+2*Z1*Z2*Z3,0,Z2^2*Z3+Z1^2*Z4+2*Z1*Z2*Z5,0,Z2^2*Z5+2*Z1*Z2*Z4,0,Z2^2*Z4]; +Eparg2 = [Z3^2,0,2*Z3*Z5,0,Z5^2+2*Z3*Z4,0,2*Z4*Z5,0,Z4^2];%epari^2 +G = [0,0,0,0,0,1,0,0,0]; %g +G2 = [0,0,0,0,0,0,1,0,0]; %g^2 +G3 = [0,0,0,0,0,0,0,1,0]; %g^3 +G4 = [0,0,0,0,0,0,0,0,1]; %g^4 +EgG = [0,0,0,0,Z1,0,Z2,0,0]; %E*g +Eg2G = [0,0,0,Z1^2,0,2*Z1*Z2,0,Z2^2,0]; %E^2*g +EgG2 = [0,0,0,0,0,Z1,0,Z2,0]; %E*g^2 +Eg2G2 = [0,0,0,0,Z1^2,0,2*Z1*Z2,0,Z2^2]; %E^2*g^2 + +% single derivatives + +% get s01 (step up from 0 to 1, X10 in the notes) +s01= -i/sqrt(27)*Eg*(2*M0 + 2*sqrt(5)*M2*blj(1,1)) + i*del/sqrt(3)*M1*G; + +% get s10 (step down from 1 to 0, X01 in the notes) +s10 = i*del*G/sqrt(3)*M0; + +% s12 (step up from 1 to 2, X21 in the notes) +s12 = -i*Eg/(3*sqrt(5))*(2*sqrt(3)*alj(2,1)^2*M1 + 2*sqrt(7)*clj(2,1)*alj(2,1)*M3) ... + + i*del*G/sqrt(3)*alj(2,0)*bhlj(2,0)*M2; + +%s21 (step down from 2 to 1, X12 in notes) +s21 = -2*i*Eg/(3*sqrt(3))*(blj(1,1)*M0 + blj(1,1)^2*sqrt(5)*M2)... + + i*del*G/sqrt(3)*blj(1,0)*M1; + +%------------- +% double derivatives +s00 = M0*(-del^2*G2/3*alj(1,0) - 2*Eg2/9*ahlj(1,1)^2 - 2/3*(del/2*Eparg + del*Eg2/x)) ... + +2*Eg2/9*sqrt(5)*M2*bhlj(2,0)*ahlj(2,0)*ahlj(1,1); + +s11 = 4*del*EgG/9*alj(2,1)^2*(M0 + blj(1,1)*sqrt(5)*M2) ... + - 2*ahlj(2,0)^2*Eg2/9*alj(2,0)*(alj(2,0)*M1 + clj(2,0)*M3*sqrt(7/3)) ... + + (-del^2*G2/3*alj(2,0) + Eg2/9*2*ahlj(1,1)*ahlj(2,0) - 2/3/sqrt(5)*del*(Eparg-Eg2/x))*alj(2,0)*M1 ... + + 2*Eg2/9*ahlj(2,0)*ahlj(1,1)*(alj(2,0)*M1+clj(2,0)*M3*sqrt(7/3))... + +(-del^2*G2/3*alj(1,0) - 2*ahlj(1,1)^2*Eg2/9 - 2*del/3*(Eparg/2+Eg2/x))*M1; + + +s02 = -2/9*Eg2*ahlj(2,2)^2 *(dlj(2,2)*M4*sqrt(9/5) + blj(2,2)*M2+M0/sqrt(5)) ... + - 2/9*Eg2*ahlj(2,0)^2*(dlj(2,0)*M4*sqrt(9/5)+blj(2,0)*M2+M0/sqrt(5)) ... + +4/3/sqrt(15)*del*EgG*alj(2,1)*(alj(2,1)*M1*sqrt(3) + clj(2,1)*M3*sqrt(7)) ... + +(-del^2*G2*alj(2,0)/3 + 2*Eg2/9*ahlj(1,1)*ahlj(2,0) - 2*del/3/sqrt(5)*(Eparg-Eg2/x))*M2; + +s20 = (-del^2*G2*alj(2,0)/3 + 2*Eg2/9*ahlj(1,1)*ahlj(2,0) - 2*del/3/sqrt(5)*(Eparg-Eg2/x))*bhlj(2,0)*M0 ... + - 2*Eg2/9*ahlj(2,0)^2*bhlj(2,0)^2*M2*sqrt(5); + +% ------------- +% triple derivatives + +v0010 = -i*del^3*G3/3/sqrt(3)*(alj(2,0)^2+alj(1,0)^2) - i*6*del*Eg2G/9/sqrt(3)*(-ahlj(2,0)*alj(2,0)*ahlj(1,1)+ahlj(1,1)^2*alj(1,0)) ... + - 6*i*del^2/3/sqrt(3)*(EpargG/2+Eg2G/x) - 6*i*del^2/3/sqrt(15)*(EpargG-Eg2G/x) *alj(2,0); + +v2010 = -i*6*del*Eg2G/9/sqrt(3)*(ahlj(2,0)^2*alj(2,0) - ahlj(1,1)*alj(1,0)*ahlj(2,0)); + +v1111 = 3*i*Eg3/27*(-ahlj(2,0)^2-ahlj(1,1))^2+3*i*del^2*EgG2/9*(alj(1,0)-alj(2,0)*ahlj(2,0)) ... + +6*i*del/9*(EpargEg/2+Eg3/x)-6*i*del/9/sqrt(5)*(EpargEg-Eg3/x)*ahlj(2,0); +v3111 = 3*i*Eg3/27*(-ahlj(2,0)^2-ahlj(1,1))*ahlj(2,0)*ahlj(3,1); + +%MRT3(ljind(3,-1),ljind(1,-1))/(8*pi^2) + +t01 = 2/sqrt(3)*v1111*(M0+blj(1,1)*M2*sqrt(5)) + 2/sqrt(3)*v3111*(bhlj(3,1)*M2*sqrt(5)+dhlj(3,1)*M4*sqrt(9)) ... + +v2010*(alj(2,0)*M1+bhlj(3,0)*M3*sqrt(7/3)) + v0010*M1; + +t10 = M0*v0010 + bhlj(2,0)*M2*sqrt(5)*v2010; + +% ----------------------- +% quadruple derivatives +v0000 = 6*Eg4/81*(ahlj(2,2)^2*ahlj(1,1))^2 ... + + del^4*G4/9*(alj(2,0)^2*alj(1,0)+alj(1,0)^3) ... + + 12*del^2*Eg2G2/27*(-alj(1,0)*ahlj(1,1)^2 + alj(2,0)*ahlj(2,0)*ahlj(1,1))*-ahlj(1,1)... + + 12*del^2/9*(Eparg2/4+Eg4/x^2+EpargEg2/x) + 12*del^2/45*(Eparg2+Eg4/x^2-2*EpargEg2/x)*bhlj(2,0) ... + + 12*del/3*(EpargG2/2+Eg2G2/x)*del^2/3*alj(1,0)... + +12*del/3*(EpargEg2/2+Eg4/x)*2/9*ahlj(1,1)^2 ... + + 12*del/3/sqrt(5)*(EpargG2-Eg2G2/x)*del^2/3*alj(2,0)*bhlj(2,0) ... + -12*del/3/sqrt(5)*(EpargEg2-Eg4/x)*2/9*ahlj(2,0)*ahlj(1,1)*bhlj(2,0); +%gvec = [1/g^4;1/g^3;1/g^2;1/g;1;g;g^2;g^3;g^4]; + + +v2000 = 6*Eg4/81 *ahlj(2,2)^2*ahlj(1,1)*(-ahlj(2,2)^2*ahlj(2,0) - ahlj(2,2)*ahlj(3,-1)*ahlj(3,1)) ... + + 12*del^2*Eg2G2/27*(-alj(1,0)*ahlj(1,1)^2 + alj(2,0)*ahlj(2,0)*ahlj(1,1))*ahlj(2,0) ... + -24*del/27*(EpargEg2/2+Eg4/x)*ahlj(2,0)*ahlj(1,1) + 24*del/27/sqrt(5)*(EpargEg2-Eg4/x)*ahlj(2,0)^2*bhlj(2,0); + +v4000 = 6*Eg4/81*ahlj(2,2)^2*ahlj(1,1)*ahlj(2,2)*ahlj(3,-1)*ahlj(4,0); + +q00 = M0*v0000 + M2*sqrt(5)*v2000 + M4*sqrt(9)*v4000; + +X1 = -1/2*(M1-5)/(M1-1)^3*conv(conv(s01,s01),conv(s10,s10)); X1 = X1(13:21); +X2 = 1/2*(M1-3)/(M1-1)^2*conv(conv(s00,s01),s10); X2 = X2(9:17); +X3 = -1/2*conv(s00,s00); X3 = X3(5:13); +X4 = -1/((M1-1)^2*(M2-1))*conv(conv(s01,s12),conv(s21,s10)); X4 = X4(13:21); +X5 = 1/(M1-1)^2*conv(conv(s01,s11),s10); X5 = X5(9:17); +X6 = 1/((M1-1)*(M2-1))*conv(conv(s02,s21),s10); X6 = X6(9:17); +X7 = 1/((M1-1)*(M2-1))*conv(conv(s01,s12),s20); X7 = X7(9:17); +X8 = -1/(M2-1)*conv(s02,s20); X8 = X8(5:13); +X9 = 1/(1-M1)*conv(t01,s10); X9 = X9(5:13); +X10 = 1/(1-M1)*conv(s01,t10); X10 = X10(5:13); +X11 = q00; + +% overall polynomial for R4l +R4lpoly = 1/del*(24*X1+24*X2+6*X3+24*X4+12*X5+12*X6+12*X7+6*X8+4*X9+4*X10+X11); +tmppoly = R4lpoly; + +% solve for gamma +R4lpoly(5) = R4lpoly(5)-R4l; + +groots = roots(fliplr(R4lpoly)); + +% want only the positive real solutions +gvals = groots(find(groots>0 & imag(groots)==0)); + +if (length(gvals) == 0) + %disp('Warning: No positive real g solution') + g = NaN; eperpi = NaN; epari = NaN; ec = NaN; +else + g = gvals; + E = Z1./gvals + Z2*gvals; + eperpi = E.^2/x; + ec = E./eperpi; + epari = Z3./gvals.^2 + Z4*gvals.^2 + Z5; +end + +%gvec = [1/g^4;1/g^3;1/g^2;1/g;1;g;g^2;g^3;g^4]; + +%s11*gvec +%[tmppoly*gvec,R4l] +%X11*gvec +%t01=t01*gvec +%t10 = t10*gvec +%q00 = q00*gvec + +eperpi = 1./(1./eperpi-ec.^2./eb); +eta = -ec/eb; + +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/dssWLClengthScale.m b/BasicWLC/dssWLC/getparams/dssWLClengthScale.m new file mode 100644 index 00000000..0bb24b41 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLClengthScale.m @@ -0,0 +1,58 @@ +function [lscale,params,Svals] = dssWLClengthScale(del,alpha,Ltot,klist,Splain,Ycouple,cutoff,LMAX,params) +% get the "length-scale of accuracy" for the discrete shearable WLC +% based on cutoff for structure factor error +% Splain is the structure factor used for comparison (must be same size as +% klist) +% alpha =eta^2*eb/eperp is the dimensionless parameter setting coupling +% strength +% if params is supplied use the given parameters +% (eb,gamma,epari,eperpi,eta) +% otherwise find the parameters to match the plain WLC for a given alpha + +X = alpha/(1+alpha); + +if (nargin<8) + LMAX=10; +end + +if (nargin<9) + % get the WLC parameters + [eb,g,epari,eperpi,eta,err,plen] = dssWLCminLpParams(del,alpha); + params = [eb,g,epari,eperpi,eta,plen,err]; +else + eb = params(1); g = params(2); epari = params(3); eperpi = params(4); eta = params(5); +end + +Svals = dssWLCstructFact(klist,del,eb,g,epari,eperpi,eta,Ycouple,Ltot,LMAX); + +errvals = abs(Svals-Splain)./Splain; +indv = find(errvals>cutoff/100); +if (length(indv)<2) + error(sprintf('Values out of range with alpha = %f', alpha)) +end +if (errvals(indv(1))>cutoff) + display(sprintf('Cannot get down to the cutoff with alpha=%f. Try extending to lower k', alpha)) + lscale=inf; + params = []; Svals = []; + return +end + +errvals = real(errvals); +% find local maxima +[pks,locs] = findpeaks(errvals(indv)); +% find the first max that's above cutoff +[a,b] = find(errvals(indv(locs))>cutoff); +if (length(b)<1) + % no local max above cutoff; search from the end + if (max(errvals)2) + R2l = Rcoeff(1); R2c = Rcoeff(2); R4l = Rcoeff(3); R4c = Rcoeff(4); +else + % these are the moment components for a continuous plain worm-like chain + R2l = 2/3; + R2c = -2/3; + R4l = -208/45; + R4c = 856/135; +end + +if (nargin<2) + X =0.5; +end + +% plen is the persistence length; we want to find the lowest persistence +% length for which a solution exists + +tol = 1e-6; +plenmin = 1; +maxtry = 100; +options = optimset('TolX',1e-8,'MaxFunEvals',1e3,'MaxIter',5e3,'TolFun',1e-8); +ebguess = 1.2; + +% first go through linearly to find an upper bound +% (lowest p where there is a solution +maxtry1 = 100; +stp = logspace(-6,log10(max(3,del)),maxtry1); +plen = plenmin; +M1func = @(eb) feval(@(x) x(2),expandFsph(del,eb,alpha,1)); +for tryc = 1:maxtry1 + plen = plenmin + stp(tryc); + + M1 = exp(-del/(plen)); + try + [ebeff,fval,errval] = fzero(@(eb) M1func(eb) - M1, ebguess,options); + catch err + disp(sprintf('Failed to solve for eb, moving to next plen. %f', plen)) + continue + end + [geff,epari,eperpi,etaeff]= dssWLCgetParams(del,ebeff,alpha,R2l,R2c,R4l); + %[plen, ebeff] + %[geff epari eperpi etaeff] + ind = find(epari>0 & eperpi>0 & etaeff > 0 & geff<1); + + if (length(ind)>0) + plenmax = plen; + if (tryc>1) + plenmin = plenmin+stp(tryc-1); + end + break + end +end + +plen = (plenmin+plenmax)/2; +for tryc = 1:maxtry + M1 = exp(-del/(plen)); + [ebeff,fval,errval] = fzero(@(eb) M1func(eb) - M1, ebguess,options); + [geff,epari,eperpi,etaeff]= dssWLCgetParams(del,ebeff,alpha,R2l,R2c,R4l); + ind = find(epari>0 & eperpi>0 & etaeff > 0); + + if (length(ind) > 0) + plenmax = plen; + else + plenmin = plen; + end + plen = (plenmin+plenmax)/2; + + if (plenmax-plenmin) < tol + break + end + + %[tryc, plenmin, plenmax, plen, length(ind)] +end +if (tryc>=maxtry); disp('WARNING: failed to find minimal plen'); end + +plen = plenmax; +M1 = exp(-del/(plen)); + +% now find the parameters given this persistence length +[ebeff,fval,errval] = fzero(@(eb) M1func(eb) - M1, ebguess,options); +[geff,epari,eperpi,etaeff]= dssWLCgetParams(del,ebeff,alpha,R2l,R2c,R4l); +ind = find(epari>0 & eperpi>0 & etaeff > 0); +geff = geff(ind); epari = epari(ind); eperpi = eperpi(ind); etaeff = etaeff(ind); +% calculate the error in the constant term of R^4, pick the solution with +% the smallest error +errcomp = zeros(size(ind)); +for c3 = 1:length(ind) + moms = dssWLCmoments(del,ebeff,geff(c3),epari(c3),eperpi(c3),etaeff(c3),1); + errcomp(c3) = (moms(end)-R4c)/R4c; +end +[a,b] = min(abs(errcomp)); + +geff = geff(b); epari = epari(b); eperpi = eperpi(b); etaeff = etaeff(b); +err = errcomp(b); +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/dssWLCmoments.m b/BasicWLC/dssWLC/getparams/dssWLCmoments.m new file mode 100644 index 00000000..72e7658b --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLCmoments.m @@ -0,0 +1,154 @@ +function moms = dssWLCmoments(del,eb,g,epari,eperpi,eta,getR4c) +% -------------------------- +% get the loworder moment components of the dssWLC with the given +% parameters +% R2l, R2c are linear and constant components of , repectively +% R4l is the linear component of +% if getR4c is present and true, also get the constant components of R^4 +% --------------------------- + +if (nargin<7) + getR4c = 0; +end + +alpha = eta^2*eb*eperpi; +ec=-eta*eb; +% inverse epsilon hat +eperphi = 1/(1/eperpi + eta^2*eb); + +LMAX=4; +[xivals,tmp] = expandFsph(del,eb,alpha,LMAX); +M0=1; +M1 = xivals(2); M2 = xivals(3); M3 = xivals(4); M4 = xivals(5); + +% -------------- +%% coupling coefficients +% go up one with D10 +alj = @(l,j) sqrt(3*(l-j)*(l+j)/((2*l+1)*(2*l-1))); +% go up one in both l and j with D11 +ahlj = @(l,j) sqrt(3/2)*sqrt((l+j)*(l+j-1)/((2*l-1)*(2*l+1))); +% stay in place with D20 +blj = @(l,j) sqrt(5)*(l^2+l-3*j^2)/((2*l-1)*(2*l+3)); +% go up 2 with D20, for j=0 +bhlj = @(l,j) 3*sqrt(5)/2/(2*l-1)*sqrt((j-l)*(j-l+1)*(j+l)*(j+l-1)/((2*l+1)*(2*l-3))); +% go up one with D30 +clj = @(l,j) -sqrt(7)*3/2*(1+5*j^2-l^2)/((2*l-3)*(2*l+3))*alj(l,j)/sqrt(3); +% stay put with D40 +dlj = @(l,j) 9/4*(35*j^4 + 3*(l-1)*l*(l+1)*(l+2) - 5*j^2*(6*l^2+6*l-5))... + /((2*l-3)*(2*l-1)*(2*l+3)*(2*l+5)); +dhlj = @(l,j) 15/2*(l^2-l-7*j^2-2)/((2*l-5)*(2*l-1)*(2*l+3))*sqrt((j-l)*(j-l+1)*(j+l)*(j+l-1)/((2*l+1)*(2*l-3))); +% ---------- +% get individual diagram steps + +% single derivatives + +% get s01 (step up from 0 to 1, X10 in the notes) +s01= -i/sqrt(27)*ec*eperphi*(2*M0 + 2*sqrt(5)*M2*blj(1,1)) + i*del*g/sqrt(3)*M1; + +% get s10 (step down from 1 to 0, X01 in the notes) +s10 = i*del*g/sqrt(3)*M0; + +% s12 (step up from 1 to 2, X21 in the notes) +s12 = -i*ec/(3*sqrt(5))*eperphi*(2*sqrt(3)*alj(2,1)^2*M1 + 2*sqrt(7)*clj(2,1)*alj(2,1)*M3) ... + + i*del*g/sqrt(3)*alj(2,0)*bhlj(2,0)*M2; + +tmp1 = i*del*g/sqrt(3)*alj(2,0)*bhlj(2,0)*M2; +%s21 (step down from 2 to 1, X12 in notes) +s21 = -2*i*ec/(3*sqrt(3))*eperphi*(blj(1,1)*M0 + blj(1,1)^2*sqrt(5)*M2)... + + i*del*g/sqrt(3)*blj(1,0)*M1; +tmp2= i*del*g/sqrt(3)*blj(1,0)*M1; +%------------- +% double derivatives +s00 = M0*(-del^2*g^2/3*alj(1,0) - 2*ec^2/9*eperphi^2*ahlj(1,1)^2 - 2/3*(del/2*epari + del*eperphi)) ... + +2*ec^2/9*eperphi^2*sqrt(5)*M2*bhlj(2,0)*ahlj(2,0)*ahlj(1,1); + +s11 = 4*del*g*ec/9*eperphi*alj(2,1)^2*(M0 + blj(1,1)*sqrt(5)*M2) ... + - 2*ahlj(2,0)^2*ec^2*eperphi^2/9*alj(2,0)*(alj(2,0)*M1 + clj(2,0)*M3*sqrt(7/3)) ... + + (-del^2*g^2/3*alj(2,0) + ec^2/9*eperphi^2*2*ahlj(1,1)*ahlj(2,0) - 2/3/sqrt(5)*del*(epari-eperphi))*alj(2,0)*M1 ... + + 2*ec^2/9*eperphi^2*ahlj(2,0)*ahlj(1,1)*(alj(2,0)*M1+clj(2,0)*M3*sqrt(7/3))... + +(-del^2*g^2/3*alj(1,0) - 2*ahlj(1,1)^2*ec^2/9*eperphi^2 - 2*del/3*(epari/2+eperphi))*M1; + +s02 = -2/9*ec^2*eperphi^2*ahlj(2,2)^2 *(dlj(2,2)*M4*sqrt(9/5) + blj(2,2)*M2+M0/sqrt(5)) ... + - 2/9*ec^2*eperphi^2*ahlj(2,0)^2*(dlj(2,0)*M4*sqrt(9/5)+blj(2,0)*M2+M0/sqrt(5)) ... + +4/3/sqrt(15)*del*g*ec*eperphi*alj(2,1)*(alj(2,1)*M1*sqrt(3) + clj(2,1)*M3*sqrt(7)) ... + +(-del^2*g^2*alj(2,0)/3 + 2*ec^2/9*eperphi^2*ahlj(1,1)*ahlj(2,0) - 2*del/3/sqrt(5)*(epari-eperphi))*M2; + +s20 = (-del^2*g^2*alj(2,0)/3 + 2*ec^2/9*eperphi^2*ahlj(1,1)*ahlj(2,0) - 2*del/3/sqrt(5)*(epari-eperphi))*bhlj(2,0)*M0 ... + - 2*ec^2/9*eperphi^2*ahlj(2,0)^2*bhlj(2,0)^2*M2*sqrt(5); + +% ------------- +% triple derivatives + +v0010 = -i*del^3*g^3/3/sqrt(3)*(alj(2,0)^2+alj(1,0)^2) - i*6*del*g*ec^2/9/sqrt(3)*eperphi^2*(-ahlj(2,0)*alj(2,0)*ahlj(1,1)+ahlj(1,1)^2*alj(1,0)) ... + - 6*i*del^2*g/3/sqrt(3)*(epari/2+eperphi) - 6*i*del^2*g/3/sqrt(15)*(epari-eperphi) *alj(2,0); +v2010 = -i*6*del*g*ec^2/9/sqrt(3)*eperphi^2*(ahlj(2,0)^2*alj(2,0) - ahlj(1,1)*alj(1,0)*ahlj(2,0)); +v1111 = 3*i*ec^3/27*eperphi^3*(-ahlj(2,0)^2-ahlj(1,1))^2+3*i*del^2*g^2*ec/9*eperphi*(alj(1,0)-alj(2,0)*ahlj(2,0)) ... + +6*i*ec*del/9*eperphi*(epari/2+eperphi)-6*i*ec*del/9/sqrt(5)*eperphi*(epari-eperphi)*ahlj(2,0); +v3111 = 3*i*ec^3/27*eperphi^3*(-ahlj(2,0)^2-ahlj(1,1))*ahlj(2,0)*ahlj(3,1); + +%MRT3(ljind(3,-1),ljind(1,-1))/(8*pi^2) + +t01 = 2/sqrt(3)*v1111*(M0+blj(1,1)*M2*sqrt(5)) + 2/sqrt(3)*v3111*(bhlj(3,1)*M2*sqrt(5)+dhlj(3,1)*M4*sqrt(9)) ... + +v2010*(alj(2,0)*M1+bhlj(3,0)*M3*sqrt(7/3)) + v0010*M1; + +t10 = M0*v0010 + bhlj(2,0)*M2*sqrt(5)*v2010; + +% ----------------------- +% quadruple derivatives +v0000 = 6*ec^4/81*eperphi^4*(ahlj(2,2)^2*ahlj(1,1))^2 ... + + del^4*g^4/9*(alj(2,0)^2*alj(1,0)+alj(1,0)^3) ... + + 12*del^2*g^2*ec^2/27*eperphi^2*(-alj(1,0)*ahlj(1,1)^2 + alj(2,0)*ahlj(2,0)*ahlj(1,1))*-ahlj(1,1)... + + 12*del^2/9*(epari/2+eperphi)^2 + 12*del^2/45*(epari-eperphi)^2*bhlj(2,0) ... + + 12*del/3*(epari/2+eperphi)*(del^2*g^2/3*alj(1,0)+2*ec^2/9*eperphi^2*ahlj(1,1)^2) ... + + 12*del/3/sqrt(5)*(epari-eperphi)*(del^2*g^2/3*alj(2,0)-2*ec^2/9*eperphi^2*ahlj(2,0)*ahlj(1,1))*bhlj(2,0); + +v2000 = 6*ec^4/81*eperphi^4 *ahlj(2,2)^2*ahlj(1,1)*(-ahlj(2,2)^2*ahlj(2,0) - ahlj(2,2)*ahlj(3,-1)*ahlj(3,1)) ... + + 12*del^2*g^2*ec^2/27*eperphi^2*(-alj(1,0)*ahlj(1,1)^2 + alj(2,0)*ahlj(2,0)*ahlj(1,1))*ahlj(2,0) ... + -24*del/27*(epari/2+eperphi)*ec^2*eperphi^2*ahlj(2,0)*ahlj(1,1) + 24*del*ec^2/27/sqrt(5)*eperphi^2*(epari-eperphi)*ahlj(2,0)^2*bhlj(2,0); + +v4000 = 6*ec^4/81*eperphi^4*ahlj(2,2)^2*ahlj(1,1)*ahlj(2,2)*ahlj(3,-1)*ahlj(4,0); + +%MRT4(ljind(4,0),1)/(8*pi^2) + +q00 = M0*v0000 + M2*sqrt(5)*v2000 + M4*sqrt(9)*v4000; + +% % ------------------------- +% %first level diagrams + + R2l = 2*s01*s10/(M1-1)/del - s00/del; + R2c = 2*s01*s10/(M1-1)^2; +% +% ------------------ +% second level diagrams + +X1 = -1/2*(M1-5)/(M1-1)^3*s01^2*s10^2; +X2 = 1/2*(M1-3)/(M1-1)^2*s00*s01*s10; +X3 = -1/2*s00^2; +X4 = -1/((M1-1)^2*(M2-1))*s01*s12*s21*s10; +X5 = 1/(M1-1)^2*s01*s11*s10; +X6 = 1/((M1-1)*(M2-1))*s02*s21*s10; +X7 = 1/((M1-1)*(M2-1))*s01*s12*s20; +X8 = -1/(M2-1)*s02*s20; +X9 = 1/(1-M1)*t01*s10; +X10 = 1/(1-M1)*s01*t10; +X11 = q00; + +X1c = 3/(M1-1)^4*s01^2*s10^2; +X2c = - 1/(M1-1)^3*s00*s01*s10; +X4c = - (3+M2*(M1-2)-2*M1+M1*(-2+M2+M1))/((M1-1)^4*(M2-1)^2)*s01*s12*s21*s10; +X5c = 2/(M1-1)^3*s01*s11*s10; +X6c = (-2+M1+M2)/((M1-1)^2*(M2-1)^2)*s02*s21*s10; +X7c = (-2+M1+M2)/((M1-1)^2*(M2-1)^2)*s01*s12*s20; +X8c = -1/(M2-1)^2*s02*s20; +X9c = -1/(1-M1)^2*t01*s10; +X10c = -1/(1-M1)^2*s01*t10; + +R4l = 1/del*(24*X1+24*X2+6*X3+24*X4+12*X5+12*X6+12*X7+6*X8+4*X9+4*X10+X11); + +if (getR4c) + R4c = (24*X1c+24*X2c+24*X4c+12*X5c+12*X6c+12*X7c+6*X8c+4*X9c+4*X10c); + moms = [R2l,R2c,R4l,R4c]; +else + moms = [R2l,R2c,R4l]; +end +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/dssWLCparams.txt b/BasicWLC/dssWLC/getparams/dssWLCparams.txt new file mode 100644 index 00000000..b857acb0 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLCparams.txt @@ -0,0 +1,60 @@ +0.01 1.3893 0.99891 1.2604e+05 2.3725e+05 259.11 2.4113e-06 0.00021121 +0.011721 1.4546 0.99866 75387 1.7732e+05 237.2 3.2206e-06 0.00024121 +0.013738 1.5065 0.99839 48282 1.3227e+05 213.08 4.3181e-06 0.00027605 +0.016103 1.517 0.99785 33576 74999 161.89 6.226e-06 0.0004158 +0.018874 1.5405 0.99741 23265 53018 138.51 8.5491e-06 0.00050227 +0.022122 1.5481 0.99677 16573 34412 112.43 1.2038e-05 0.00066107 +0.025929 1.5649 0.99624 11822 26073 99.205 1.6292e-05 0.00074517 +0.030392 1.568 0.99546 8600 17961 82.81 2.2633e-05 0.00092434 +0.035622 1.5848 0.99459 6142.9 12924 71.288 3.0994e-05 0.0010979 +0.041753 1.5832 0.99317 4444.8 8078.5 56.614 4.4159e-05 0.0015028 +0.048939 1.5818 0.9923 3342.2 6387 50.61 5.8957e-05 0.0016245 +0.057362 1.5742 0.99074 2502.5 4388.2 42.047 8.2134e-05 0.0020237 +0.067234 1.5765 0.98907 1854.7 3168.7 36.085 0.00011275 0.0023991 +0.078805 1.5733 0.98675 1383.9 2152.3 29.964 0.0001572 0.0030276 +0.092367 1.5734 0.98426 1036 1528 25.531 0.00021616 0.003657 +0.10826 1.5729 0.98127 779.72 1081.5 21.753 0.0002966 0.0044347 +0.1269 1.5746 0.97806 589.76 793.29 18.939 0.00040114 0.0051922 +0.14874 1.5726 0.97366 449.26 548.77 16.003 0.00055133 0.0064618 +0.17433 1.5727 0.96886 344.63 392.95 13.816 0.00075187 0.0077757 +0.20434 1.5722 0.963 266.69 277.82 11.881 0.0010247 0.0094976 +0.2395 1.5716 0.95609 208.6 196.27 10.244 0.0013892 0.011636 +0.28072 1.5707 0.94807 165.31 139.31 8.8783 0.0018677 0.014224 +0.32903 1.5677 0.93875 133.36 98.947 7.7017 0.0025008 0.017427 +0.38566 1.5622 0.92778 109.54 70.004 6.6581 0.003371 0.021516 +0.45204 1.5539 0.91541 91.402 50.234 5.7717 0.0045193 0.026276 +0.52983 1.5417 0.90171 77.102 36.91 5.0121 0.006012 0.031445 +0.62102 1.5252 0.8863 65.188 27.777 4.3277 0.007935 0.036899 +0.7279 1.5055 0.87001 54.418 22.103 3.7488 0.010551 0.041058 +0.85317 1.4842 0.85273 44.35 18.722 3.2384 0.013947 0.043049 +1 1.4646 0.83456 35.107 17.067 2.777 0.01824 0.042062 +1.1 1.4614 0.81725 28.894 14.733 2.5829 0.021131 0.046192 +1.2 1.4574 0.8004 24.338 12.987 2.4284 0.023932 0.05008 +1.3 1.4527 0.784 20.921 11.625 2.3012 0.026973 0.053826 +1.4 1.4475 0.76795 18.303 10.513 2.1923 0.029911 0.057605 +1.5 1.4419 0.75181 16.268 9.5129 2.0895 0.032785 0.061993 +1.6 1.4359 0.73685 14.626 8.7798 2.0115 0.035564 0.065555 +1.7 1.4296 0.72254 13.289 8.1802 1.9459 0.038584 0.06887 +1.8 1.4231 0.70851 12.192 7.6397 1.8848 0.041468 0.072433 +1.9 1.4164 0.69505 11.274 7.182 1.8318 0.044228 0.075846 +2 1.4096 0.68218 10.497 6.7923 1.7857 0.046899 0.079091 +2.1 1.4026 0.6698 9.8323 6.451 1.7446 0.049515 0.082269 +2.2 1.3956 0.65784 9.2594 6.1463 1.7072 0.052135 0.085446 +2.3 1.3885 0.64653 8.7584 5.8914 1.6757 0.054898 0.088278 +2.4 1.3813 0.63527 8.3235 5.6333 1.6428 0.057573 0.09164 +2.5 1.3741 0.62487 7.9343 5.4357 1.6179 0.060118 0.094231 +2.6 1.3668 0.61464 7.5907 5.2407 1.5929 0.062599 0.097132 +2.7 1.3596 0.60485 7.2828 5.0681 1.5706 0.065009 0.099877 +2.8 1.3523 0.59536 7.0066 4.907 1.5496 0.067367 0.10267 +2.9 1.3451 0.58635 6.7559 4.7683 1.5316 0.069675 0.10517 +3 1.3379 0.57756 6.5292 4.6351 1.5142 0.071953 0.10779 +3.1 1.3306 0.5692 6.3217 4.5195 1.4992 0.074199 0.11015 +3.2 1.3234 0.56102 6.1328 4.406 1.4843 0.076506 0.11267 +3.3 1.3163 0.55317 5.9589 4.3044 1.4711 0.078846 0.11503 +3.4 1.3091 0.54549 5.7994 4.2044 1.4578 0.08112 0.11755 +3.5 1.302 0.53834 5.6505 4.1258 1.4481 0.083326 0.11948 +3.6 1.2949 0.53106 5.5145 4.0338 1.4357 0.085487 0.12209 +3.7 1.2879 0.52432 5.3866 3.9633 1.427 0.087592 0.12403 +3.8 1.2809 0.51755 5.2686 3.8851 1.4167 0.089657 0.12644 +3.9 1.274 0.51124 5.1574 3.8235 1.4093 0.091681 0.12829 +4 1.2671 0.50516 5.0532 3.7671 1.4026 0.093672 0.13003 diff --git a/BasicWLC/dssWLC/getparams/dssWLCstructFact.m b/BasicWLC/dssWLC/getparams/dssWLCstructFact.m new file mode 100644 index 00000000..c07fe019 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/dssWLCstructFact.m @@ -0,0 +1,208 @@ +% stuff for testing only +% load('lengthscales.mat') +% dc = 15; del = dellist(dc); +% [lp,g,epari,eperpi,ec,err,plen] = discreteWLCshearParams(del,Xminvals(dc)); +% eperpi = 1/(1/eperpi-ec^2/lp); +% eb = lp; +% eta = -ec/eb; +function [Svals,LMAX] = dssWLCstructFact(klist,del,eb,g,epari,eperpi,eta,Ycouple,Ltot,LMAXin) + +%% +% --------- +% Find the structure factor for a dssWLC model +% ---------- + + +pmax = 10; % maximum power to which exponential is expanded +nk = length(klist); + +eperpih = 1/(1/eperpi + eta^2*eb); +alpha = eta^2*eb*eperpi; + +%% +% expand F in terms of spherical harmonics +if (eperpi==0) + % non-shearable WLC, do direct projection using plane wave decomposition + for c = 0:LMAXin + xivals(c+1) = besseli(c+0.5,eb/del)/besseli(0.5,eb/del); + end +else + xivals = expandFsph(del,eb,alpha,LMAXin); +end + +LMAX=LMAXin; +% cut off LMAX such that xi values are decreasing +% tmp = diff(abs(xivals)); +% ind = find(tmp>0); +% if (length(ind)>0) +% LMAX = ind(1)-1; +% xivals = xivals(1:LMAX+1); +% else +% LMAX=LMAXin; +% end +%% +Imax = ljind(LMAX,LMAX); +% ---- +%% get the coefficients h_a,b^j for the spherical harmonic expansion of +% exp(H) just for 1 specific k value, in order to find the nonzero elements +% in the sparse matrices +%Hmat(a,b) has the coefficient for Y_a*(u0hat) Y_b(uhat) +% basically we're working in the linear space of pairs of Y functions + +k = klist(end); + +% get the coefficients for pairs of Y in the H matrix +Hmat = sparse(zeros(Imax,Imax)); +Hmat(ljind(1,0),1) = i*k*del*g*4*pi/sqrt(3); +Hmat(ljind(2,0),1) =-k^2*del/3*4*pi/sqrt(5)*(epari - eperpih); +Hmat(1,1) = -k^2*del/2*eperpih*4*pi + Hmat(ljind(2,0),1)*sqrt(5)/2; +Hmat(ljind(1,1),ljind(1,1)) = eta*eb*eperpih*i*k*4*pi/3; +Hmat(ljind(1,-1),ljind(1,-1)) = eta*eb*eperpih*i*k*4*pi/3; + +% get the spherical harmonic expansion coefficients for exp(H) by expanding the exponential as a +% power series in the Ys (accurate for small k) + +% Hpow contains the sph harmonic expansion of H to +% different powers +Hpow = {}; +% 0th power +Hpow{1} = sparse(zeros(Imax,Imax)); +Hpow{1}(1,1) = 4*pi; + +% 1st power +Hpow{2} = Hmat; + +[a1list,b1list,vals1] = find(Hmat); +nv1= length(a1list); + +% coefficients for the exp(H) matrix +expHmat = Hpow{1}; +if (pmax>=2) + expHmat = expHmat + Hpow{2}; +end + +for p = 2:pmax + Hpow{p+1} = sparse(zeros(Imax,Imax)); + [a2list,b2list,vals2] = find(Hpow{p}); + nv2 = length(a2list); + for c1 = 1:nv1 + aind1 = a1list(c1); + bind1 = b1list(c1); + for c2 = 1:nv2 + aind2 = a2list(c2); + bind2 = b2list(c2); + % product of 2 pairs of sph harmonics, expand into a asum over + % single pairs + Hpow{p+1} = Hpow{p+1} + vals1(c1)*vals2(c2)*transpose(Ycouple{aind1}(aind2,1:Imax))*Ycouple{bind1}(bind2,1:Imax); + end + end + + expHmat = expHmat + 1/factorial(p)*Hpow{p+1}; + +end + + +%% get M tensor elements, independent of k value (so long as nonzero +% form of expHmat remains the same) +%Mmat{c}(l,l0) is the value for the c-th pair of a,j and b,j indices + +[aind,bind,vals] = find(expHmat); + +Mmat={}; +for c = 1:length(aind) + %[c, size(Mmat), length(aind)] + a = aind(c); b = bind(c); + [al,aj] =ljindinv(a); [bl,bj] = ljindinv(b); + + Mmat{c} = sparse(zeros(LMAX+1,LMAX+1)); + + for l0 = 0:LMAX + [lind,tmp,al0vals] = find(Ycouple{ljind(l0,0)}(1:Imax,a)); + + for lc = 1:length(lind) + [ll,tmp] = ljindinv(lind(lc)); + + for lam = max(0,abs(bl-ll)):min(LMAX,bl+ll) + tmp = Ycouple{b}(ljind(lam,0),ljind(ll,bj)); + if (abs(tmp)>0) + Mmat{c}(ll+1,l0+1) = Mmat{c}(ll+1,l0+1) + tmp*al0vals(lc)... + *xivals(lam+1)*sqrt((2*lam+1)/(2*ll+1)); + end + end + end + end +end + +%% get overall structure factor, recalculating h_a,b^j for each specific k +% value +for kc = 1:nk + + k = klist(kc); + + % get the coefficients for pairs of Y in the H matrix + Hmat = sparse(zeros(Imax,Imax)); + Hmat(ljind(1,0),1) = i*k*del*g*4*pi/sqrt(3); + Hmat(ljind(2,0),1) =-k^2*del/3*4*pi/sqrt(5)*(epari - eperpih); + Hmat(1,1) = -k^2*del/2*eperpih*4*pi + Hmat(ljind(2,0),1)*sqrt(5)/2; + Hmat(ljind(1,1),ljind(1,1)) = eta*eb*eperpih*i*k*4*pi/3; + Hmat(ljind(1,-1),ljind(1,-1)) = eta*eb*eperpih*i*k*4*pi/3; + + % get the spherical harmonic expansion coefficients for exp(H) by expanding the exponential as a + % power series in the Ys (accurate for small k) + + % Hpow contains the sph harmonic expansion of H to + % different powers + Hpow = {}; + % 0th power + Hpow{1} = sparse(zeros(Imax,Imax)); + Hpow{1}(1,1) = 4*pi; + + % 1st power + Hpow{2} = Hmat; + + [a1list,b1list,vals1] = find(Hmat); + nv1= length(a1list); + + % coefficients for the exp(H) matrix + expHmat = Hpow{1}; + if (pmax>=2) + expHmat = expHmat + Hpow{2}; + end + + for p = 2:pmax + Hpow{p+1} = sparse(zeros(Imax,Imax)); + [a2list,b2list,vals2] = find(Hpow{p}); + nv2 = length(a2list); + for c1 = 1:nv1 + aind1 = a1list(c1); + bind1 = b1list(c1); + for c2 = 1:nv2 + aind2 = a2list(c2); + bind2 = b2list(c2); + % product of 2 pairs of sph harmonics, expand into a asum over + % single pairs + Hpow{p+1} = Hpow{p+1} + vals1(c1)*vals2(c2)*transpose(Ycouple{aind1}(aind2,1:Imax))*Ycouple{bind1}(bind2,1:Imax); + %Hpow{p+1} = Hpow{p+1} + vals1(c1)*vals2(c2)*transpose(Ycoupleflip{aind1}(1:Imax,aind2))*Ycoupleflip{bind1}(1:Imax,bind2); + end + end + + expHmat = expHmat + 1/factorial(p)*Hpow{p+1}; + end + + % overall matrix of g coefficients + [aind,bind,vals] = find(expHmat); + gcoeff = zeros(LMAX+1,LMAX+1); + + for c = 1:length(aind) + gcoeff = gcoeff + Mmat{c}*vals(c); + end + + % number of segments + nseg = Ltot/del; + + % now find the structure factor + I = eye(LMAX+1); + gtot = ((nseg+1)*I+gcoeff^(nseg+2) - gcoeff*(nseg+2))*inv(gcoeff-I)^2; + Svals(kc) = 2*gtot(1,1)/(nseg+1)^2; + +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/expandFsph.m b/BasicWLC/dssWLC/getparams/expandFsph.m new file mode 100644 index 00000000..2e69625a --- /dev/null +++ b/BasicWLC/dssWLC/getparams/expandFsph.m @@ -0,0 +1,87 @@ +function [xivals,tmp] = expandFsph(del,eb,alpha,LMAX) +% for the dssWLC model structure factor and moment calculations, +% expand the function F(uhat) in terms of spherical harmonics of uhat +% del is the discretization length +% eb is the bending modulus +% eperpi is 1/shear modulus +% eta is the bend-shear coupling +% WARNING: this becomes unstable at higher indices for higher eperpih + +a = eb/del; +b = alpha*eb/(1+alpha)/2/del; +tmp = b/a^2; +Ivals = zeros(LMAX+1,1); + +%for n = 0:LMAX +% Ivals(n+1) = quad(@(x) x.^n.*exp(a*x-b*x.^2),-1,1,1e-12); +%end +% +% %% + +cutoff = 0.05e-2; +%[b/a^2, cutoff] +% below this cutoff, use an expansion of the quadratic part of the integral +if (b/a^2 < cutoff) + %% + % get the J integrals (incomplete gamma functions) + % rescale all J by multiplying by exp(-a)/a^m + pmax = ceil(log(eps)/log(b/a^2)+5); % maximum power to go to + indmax = 2*pmax+LMAX; + Jvals = zeros(2*pmax+LMAX+1,1); + Jvals(1) = (1 - exp(-2*a)); + for m = 1:indmax + Jvals(m+1) = -m/a*Jvals(m) + (1-(-1)^m*exp(-2*a)); + end + + % get the I_n integrals, multiplied by exp(-a) + ks = 0:pmax; + for n = 0:LMAX + Ivals(n+1) = sum(1/a*(-1).^(ks).*b.^ks.*Jvals(n+2*ks+1)'./factorial(ks)); + end +% %% +else + %% +% for n = 0:LMAX +% Ivals(n+1) = quad(@(x) x.^n.*exp(a*x-b*x.^2),-1,1,1e-16); +% end +% end + % more asymptotics to avoid bad erf values + cutoff2 = 4.5; + if ((a-2*b)/2/sqrt(b) 21 + + +tic +% maximal indices +Imax = ljind(LMAX,LMAX); +Imax3 = ljind(2*LMAX,2*LMAX); +% set up an array of sparse matrices +W3Jsparse = cell(Imax,1); +for ind1 = 1:Imax + W3Jsparse{ind1} = sparse(zeros(Imax,Imax3)); + Ycouple{ind1} = sparse(zeros(Imax,Imax3)); +end + +%% pretabulate factorials +factsave = zeros(4*LMAX+1,1); +for c = 1:4*LMAX+1 + factsave(c) = factorial(c); +end +%% +% get the Wigner3j coefficients +for l1 = 0:LMAX + l1 + for j1 = -l1:l1 + ind1 = ljind(l1,j1); + [l1,j1] + + for l2 = 0:LMAX + for j2 = -l2:l2 + ind2 = ljind(l2,j2); + + for l3 = abs(l1-l2):l1+l2 + j3 = j1+j2; + if abs(j3)>l3 + continue + end + ind3 = ljind(l3,j3); + if (mod(l1+l2+l3,2)>0); continue; end + + W3Jsparse{ind1}(ind2,ind3) = Wigner3j(l1,l2,l3,j1,j2,-j3,factsave); + end + end + end + end +end +toc + +% ----------------------- +%% tabulate coupling coefficients +tic +Imax = ljind(LMAX,LMAX); + +for l1 = 0:LMAX + l1 + for j1 = -l1:l1 + ind1 = ljind(l1,j1); + for l2 = 0:LMAX + for j2 = -l2:l2 + ind2 = ljind(l2,j2); + + for l3 = abs(l1-l2):min(LMAX,l1+l2) + j3 = j1+j2; + if abs(j3)>l3 + continue + end + ind3 = ljind(l3,j3); + if (mod(l1+l2+l3,2)>0); continue; end + + C1 = W3Jsparse{ljind(l1,0)}(ljind(l2,0),ljind(l3,0)); + C2 = W3Jsparse{ind1}(ind2,ind3); + + Ycouple{ind1}(ind2,ind3) = sqrt((2*l1+1)*(2*l2+1)*(2*l3+1)/(4*pi))... + *(-1)^(j1+j2)*C1*C2; + end + end + end + end +end +toc + +if (nargin>1) + save(savefile,'LMAX','Imax','Imax3','Ycouple','W3Jsparse') +end +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/ljind.m b/BasicWLC/dssWLC/getparams/ljind.m new file mode 100644 index 00000000..dec2e9a5 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/ljind.m @@ -0,0 +1,7 @@ +function ind = ljind(l,j) +if (abs(j)<= l) + ind = l^2+j+l+1; +else + ind = 0; +end +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/ljindinv.m b/BasicWLC/dssWLC/getparams/ljindinv.m new file mode 100644 index 00000000..94919e7c --- /dev/null +++ b/BasicWLC/dssWLC/getparams/ljindinv.m @@ -0,0 +1,11 @@ +function [l,j] = ljindinv(a) +% for indexing wigner functions where the m index is ignored +% returns the l,j indices corresponding to the effective single index a + +if (a<=0) + l=NaN;j=NaN; +else + l = floor(sqrt(a-1)); + j = a - l^2-l-1; +end +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/shearWLCgetAmat.m b/BasicWLC/dssWLC/getparams/shearWLCgetAmat.m new file mode 100644 index 00000000..fe56992b --- /dev/null +++ b/BasicWLC/dssWLC/getparams/shearWLCgetAmat.m @@ -0,0 +1,28 @@ +function A = shearWLCgetAmat(k,eb,g,epari,ephi,eta,LMAX) +% get the A matrix for a continuous shearable WLC at a particular k value +% uses parameters as defined in the manuscript + +lp = eb/(1+eta^2*eb*ephi); + +alj = @(l,j) sqrt((l-j)*(l+j)/((2*l-1)*(2*l+1))); +blj = @(l,j) alj(l,j)*alj(l-1,j); +clj = @(l,j) alj(l,j)^2 + alj(l+1,j)^2; +A = zeros(LMAX+1,LMAX+1); +for l = 0:LMAX + lind=l+1; + A(lind,lind) = l*(l+1)/2/lp +k^2/2*ephi*(1-clj(l,0)) + k^2/2*epari*clj(l,0); + if (l < LMAX) + A(lind,lind+1) = -i*g*k*alj(l+1,0) - i*k*eta*ephi*l*alj(l+1,0); + end + if (l>0) + A(lind,lind-1) = -i*g*k*alj(l,0) + i*k*eta*ephi*(l+1)*alj(l,0); + end + if (l < LMAX-1) + A(lind,lind+2) = -k^2/2*ephi*blj(l+2,0) + k^2/2*epari*blj(l+2,0); + end + if (l>1) + A(lind,lind-2) = -k^2/3*ephi*blj(l,0) + k^2/2*epari*blj(l,0); + end +end + +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/shearWLCpropagator.m b/BasicWLC/dssWLC/getparams/shearWLCpropagator.m new file mode 100644 index 00000000..e0db4473 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/shearWLCpropagator.m @@ -0,0 +1,23 @@ +function M = shearWLCpropagator(k,L,lp,g,epari,ephi,eta,LMAX) +% get structure factor at a particular k value +% for a shearable WLC +% = InverseLaplace(G(k,p)) +% get the propagator matrix for a shearable WLC of length L + +% get the matrix +A = shearWLCgetAmat(k,lp,g,epari,ephi,eta,LMAX); +% get the poles +evals = eig(-A); +[tmp1,tmp2] = sort(real(evals),'descend'); +evals = evals(tmp2); + +% get the exponential components +M = zeros(LMAX+1,LMAX+1); +for ec = 1:LMAX+1 + cA = cofactor(evals(ec)*eye(LMAX+1)+A); + p = evals(ec); + expterm = cA/(prod(p-evals(1:ec-1))*prod(p-evals(ec+1:end))); + M = M + expterm*exp(evals(ec)*L); +end + +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/ssWLCdynamics.m b/BasicWLC/dssWLC/getparams/ssWLCdynamics.m new file mode 100644 index 00000000..318c3b1a --- /dev/null +++ b/BasicWLC/dssWLC/getparams/ssWLCdynamics.m @@ -0,0 +1,45 @@ +function [evals,evecs,pareval,Amat] = ssWLCdynamics(eb,g,epar,eperph,eta,L,xir,xiu,pmax) +% get the eigenvalues and eigenvectors for continuous shearable WLC +% dynamics, using mode decomposition of the coupled shear and bend +% pareval is the eigenvalue for stretch + +if (nargin<9) + pmax = 100; +end + +Amat = zeros(2*pmax); +% for each p, lists X1,O2 +for p = 1:pmax + x1i = 2*(p-1)+1; + o2i = 2*(p-1)+2; + + coeff = pi^2*p^2/L^2; + + Amat(x1i,x1i) = -(eperph/xir*coeff + g^2*eperph/xiu); + Amat(x1i,o2i) = eta*eb/xir*coeff+eta*eb*g^2/xiu; + Amat(o2i,o2i) = (-eb/xiu*coeff); + Amat(o2i,x1i) = eta*eb/xiu*coeff; + + for pp = 1:pmax + if (mod(pp+p,2)==1) + x1ip = 2*(pp-1)+1; + o2ip = 2*(pp-1)+2; + + tmp = 4*g/L/xiu*(p*pp)/(p^2-pp^2); + + Amat(x1i,x1ip) = Amat(x1i,x1ip) +tmp*eta*eb; + Amat(x1i,o2ip) = Amat(x1i,o2ip) -tmp*eb; + Amat(o2i,o2ip) = Amat(o2i,o2ip) -tmp*eta*eb; + Amat(o2i,x1ip) = Amat(o2i,x1ip) +tmp*eperph; + % [p,pp,x1i,o2ip,o2i,x1ip, Amat(x1i,o2ip),Amat(o2i,x1ip)] + end + end +end +[V,E] = eig(Amat); E = diag(E); +[a,b] = sort(real(E)); +evals = E(b); +evecs = V(:,b); + +pareval = -epar/xir*pi^2/L^2; + +end \ No newline at end of file diff --git a/BasicWLC/dssWLC/getparams/tabulateparams.m b/BasicWLC/dssWLC/getparams/tabulateparams.m new file mode 100644 index 00000000..27d544c2 --- /dev/null +++ b/BasicWLC/dssWLC/getparams/tabulateparams.m @@ -0,0 +1,115 @@ +%----------------------------------------------- +% Tabulate the dssWLC energetic parameters for del=0.01 to del=1 +% Optimizing over alpha to get minimal length scale of accuracy +% delvals = delta values +% Resulting parameters are in: ebvals, gvals, eparvals, eperpvals, etavals, +% alphavals +% Structure factor for dssWLC with delta=delvals(dc), for wavevectors klist(dc,:) +% are in Svals(dc,:) +% Corresponding structure factor for continuous chain is in Splain(dc,:) +% Structure factor errors are in errvals(dc,:) +% Length scales of accuracy are in: lscales +% Results are saved in dssWLCparams.mat +% ----------------------------------------------- +LMAX=20; +Ycouple = getYcouple(LMAX,'YcoupleSave.mat') +delvals = logspace(-2,0,30); +nd = length(delvals); +nk = 100; +Ltot = 1000; +cutoff=1e-4; + +LMAXvals = 10*ones(size(delvals)); +LMAXvals(1:10) = 14; + +for dc = 5:5 + del = delvals(dc); + LMAX = LMAXvals(dc); + + klist(dc,:) = logspace(log10(1/del/10),log10(1/del*4),nk); + + % get plain wlc structure factor + nseg = Ltot/del; + I = eye(LMAX+1); + for kc = 1:nk + Mplain = shearWLCpropagator(klist(dc,kc),del,1,1,0,0,0,LMAX); + Mtot = ((nseg+1)*I+Mplain^(nseg+2) - Mplain*(nseg+2))*inv(Mplain-I)^2; + Splain(dc,kc) = 2*Mtot(1,1)/(nseg+1)^2; + end + + options = optimset('Display','iter','TolX',1e-4); + if (dc==1) + alpharange = [0.1,1]; + else + alpharange = [alphavals(dc-1)-0.2,alphavals(dc-1)+0.2]; + end + [alphavals(dc),lscalesave(dc)] = fminbnd(@(alpha) dssWLClengthScale(del,alpha,Ltot,klist(dc,:),Splain(dc,:),Ycouple,cutoff,LMAX),... + alpharange(1),alpharange(2),options); + [lscales(dc),params,Svals(dc,:)] = dssWLClengthScale(del,alphavals(dc),Ltot,klist(dc,:),Splain(dc,:),Ycouple,cutoff,LMAX); + + errvals(dc,:) = abs(Svals(dc,:)-Splain(dc,:))./Splain(dc,:); + ebvals(dc) = params(1); + gvals(dc) = params(2); + eparvals(dc) = 1/params(3); + eperpvals(dc) = 1/params(4); + etavals(dc) = params(5); + + [dc del alphavals(dc) eperpvals(dc)] + + save('dssWLCparams.mat') +end + +%% find energetic params for del>1 using fixed alpha +load('dssWLCparams.mat') +delvals = [delvals,1.1:0.1:4]; +ndtot = length(delvals); +alphaset = alphavals(nd); +for dc = nd+1:ndtot + del = delvals(dc); + [ebvals(dc),gvals(dc),epari,eperpi,etavals(dc),err,plen] = dssWLCminLpParams(del,alphaset); + eparvals(dc) = 1/epari; + eperpvals(dc) = 1/eperpi; + alphavals(dc) = alphaset; + [dc del alphavals(dc) eperpvals(dc)] +end + +%% +% find appropriate xiu value +for dc = 1:ndtot + del = delvals(dc); + eb = ebvals(dc); + gam = gvals(dc); + eperp = eperpvals(dc); + epar = eparvals(dc); + eta = etavals(dc); + + eperph = eperp + eta^2*eb; + xir = 1; + xiulist = logspace(-7,1,50); + L=del; + pval = 1; + tfast = zeros(size(xiulist)); + + for uc = 1:length(xiulist) + xiu = xiulist(uc); + [evals,evecs,pareval] = ssWLCdynamics(eb,gam,epar,eperph,eta,L,xir,xiu,50); + tfast(uc) = -1/evals(end); + end + + dt = diff(log10(tfast)); + lxiu = interp1(dt,log10(xiulist(1:end-1)),(dt(1)+dt(end))/2); + zetauvals(dc) = 10^lxiu; + + % get the appropriate delt + deltsclvals(dc) = 0.5/(eperp*gam^2*del); + + [dc, del, zetauvals(dc), deltsclvals(dc)] +end + +%% +% output a space-delimited look-up table of values + +lastind = length(ebvals); +datamat = [delvals(1:lastind)',ebvals(1:lastind)',gvals(1:lastind)',eparvals(1:lastind)',... + eperpvals(1:lastind)', etavals(1:lastind)',zetauvals(1:lastind)',deltsclvals(1:lastind)']; +dlmwrite('dssWLCparams.txt',datamat,' '); diff --git a/BasicWLC/dssWLC/getparams/testrun.m b/BasicWLC/dssWLC/getparams/testrun.m new file mode 100644 index 00000000..c8a3208f --- /dev/null +++ b/BasicWLC/dssWLC/getparams/testrun.m @@ -0,0 +1,7 @@ +% -------- +%% test all the code for dssWLC calculations +% --------- + +% tabulate coupling coefficients for spherical harmonics +% only have to do this once and then save results +Ycouple = getYcouple(LMAX,'YcoupleSave.mat') \ No newline at end of file diff --git a/BasicWLC/dssWLC/scripts/pdbutils.py b/BasicWLC/dssWLC/scripts/pdbutils.py new file mode 100644 index 00000000..9c581e63 --- /dev/null +++ b/BasicWLC/dssWLC/scripts/pdbutils.py @@ -0,0 +1,450 @@ +# generic objects and utilities for dealing with pdb files +import re +from numpy import * + +# regular expression for an atom in a pdb file +atomR = re.compile('^(ATOM|HETATM) *([0-9]+) *(\S+) +([A-Z]+) +([a-zA-Z]?) *\ +([-0-9]+) *(-?[0-9.]+) *(-?[0-9.]+) *(-?[0-9.]+)(.*$)') + +# regular expression for a biological symmetry transform line +transformR = re.compile('^REMARK +350 +BIOMT[1-3] *(\d+) +(-?[0-9.]+) +(-?[0-9.]+) +(-?[0-9.]+) +(-?[0-9.]+) *$') + + +class Atom: + """This object represents information concerning a single atom""" + def __init__(self,pdbmatch = None,coords = None, name = 'X',num=0): + """Fill in information using a match object from a pdb file""" + if pdbmatch != None: + # base the atom information on a match object from a pdb line + self.type = pdbmatch.group(1) + self.num = int(pdbmatch.group(2)) + self.name = pdbmatch.group(3) + self.res = pdbmatch.group(4).strip() + self.chain = pdbmatch.group(5) + self.resnum = int(pdbmatch.group(6)) + self.x = float(pdbmatch.group(7)) + self.y = float(pdbmatch.group(8)) + self.z = float(pdbmatch.group(9)) + self.coords = array([self.x,self.y,self.z]) + self.occupancy = None + self.bfactor = None + self.tail = pdbmatch.group(10) + + elif coords != None: + # give the atom the desired coordinates and type + self.num = num + self.coords = coords + [self.x,self.y,self.z] = coords + self.name = name + self.res = 'SSN' + self.resnum = 0 + self.chain = 'X' + self.occupancy = 1 + self.bfactor = 1 + self.tail = ' C' + self.type = 'HETATM' + + self.coords = array(self.coords) + self.chainobj = None + self.resobj = None + self.conect = [] + + def __repr__(self): + return "" %(self.num, self.name, self.resnum, self.chain) + + def pdbline(self): + """Get the pdb line corresponding to this atom""" + + if (self.occupancy==None or self.bfactor == None): + line = '%s%5d %s%3s%2s%4d%12.3f%8.3f%8.3f%s\n' \ + %(self.type.ljust(6),self.num,self.name.ljust(4),self.res,self.chain,self.resnum,\ + self.coords[0],self.coords[1],self.coords[2],self.tail) + else: + line = '%s%5d %s%3s%2s%4d%12.3f%8.3f%8.3f%6.2f%6.2f%s\n' \ + %(self.type.ljust(6),self.num,self.name.ljust(4),self.res,self.chain,self.resnum,\ + self.coords[0],self.coords[1],self.coords[2],self.occupancy,self.bfactor,self.tail) + + return line + + def conline(self): + """Get a CONECT line for this atom""" + + str = 'CONECT%5d' %(self.num) + for a in self.conect: + str += '%5d' %a.num + str += '\n' + return str + +class Residue: + """Residue or nucleotide object""" + def __init__ (self,atoms=None): + if atoms == None: + self.atoms = [] + self.num = None + self.chain = None + self.name = None + else: + self.atoms = atoms + self.chain = atoms[0].chain + self.num = atoms[0].resnum + self.name = atoms[0].res + + def __repr__(self): + return "" %(self.num, self.name) + + def getAtomByName(self,name,regexp=0): + """Return the first atom with the given name found in the residue. If regexp is true, then get the atom whose name matches the regular expression""" + if regexp: + rN = re.compile(name) + for a in self.atoms: + if rN.search(a.name) != None: + return a + else: + for a in self.atoms: + if a.name == name: + return a + + return None + +class Chain: + """Chain object""" + def __init__(self,residues = None): + if residues == None: + self.residues=[] + self.name = None + else: + self.residues = residues + self.name = self.residues[0].chain + def __repr__(self): + return "" %self.name + + def fromAtomList(self,atmlist): + # set up a chain from a list of atom objects + # split them up into residues + # raises error if they don't all have the same chain name + + self.residues = [] + self.name = atmlist[0].chain + + start = 0 + for a in atmlist: + if a.chain != self.name: + raise ValueError("Atmlist does not all have the same chain name %s %s" %(self.name, a.chain)) + + if not start or a.resnum!= res.num: + if start: + self.residues.append(res) + res = Residue() + res.name = a.res; res.num = a.resnum + res.chain = a.chain; + res.atoms = [a] + start = 1 + else: + res.atoms.append(a) + + self.residues.append(res) + + return 0 +class BasePair: + """DNA base pair object. Contains 2 residues and a list of atoms""" + def __init__(self,residues = None): + self.atoms = [] + if residues == None: + self.residues = [] + else: + self.residues = residues + for r in residues: + self.atoms.extend(r.atoms) + + if len(self.residues) != 0 and len(self.residues) != 2: + print "WARNING: creating base-pair with neither 0 nor 2 residues" + + def __repr__(self): + return "" %(self.residues[0].name,self.residues[1].name) + +def goodPair(r1,r2): + """Check if two DNA/RNA residues make a correct basepair""" + + return (r1.name[-1] == 'A' and r2.name[-1] == 'T') \ + or (r1.name[-1] == 'T' and r2.name[-1] == 'A') \ + or (r1.name[-1] == 'G' and r2.name[-1] == 'C') \ + or (r1.name[-1] == 'C' and r2.name[-1] == 'G') \ + or (r1.name=='THY' and r2.name=='ADN') \ + or (r1.name=='ADN' and r2.name=='THY') \ + or (r1.name=='CYT' and r2.name=='GUA') \ + or (r1.name=='GUA' and r2.name=='CYT') + +class Structure: + """Class containing an molecule or multi-molecule structure""" + def __init__(self,infile = None): + self.initvars() + + if infile != None: + self.structFromFile(infile) + + def renumRes(self): + """Renumber the residues""" + for c in range(len(self.residues)): + self.residues[c].num = c+1 + for a in self.residues[c].atoms: + a.resnum = c+1 + + def resetFromResidues(self): + # reset the chains and atoms in a structure when the residue list is set + + # rebuild the list of chains + # dictionary mapping chain objects to their names + self.chains = []; + chainnames = {} + + for r in self.residues: + if r.chain in chainnames.keys(): + chainnames[r.chain].residues.append(r) + chainnames[r.chain].atoms.extend(r.atoms) + else: + chainnames[r.chain] = Chain() + self.chains.append(chainnames[r.chain]) + chainnames[r.chain].name = r.chain + chainnames[r.chain].residues = [r] + chainnames[r.chain].atoms = r.atoms[:] + for a in r.atoms: + a.chain = r.chain + + # rebuild atom list + self.atoms = [] + [self.atoms.extend(r.atoms) for r in self.residues] + + def resetFromChains(self): + # reset the residues and atoms based on the chains + + self.residues = []; self.atoms = [] + for c in self.chains: + self.residues.extend(c.residues) + for r in c.residues: + r.chain = c.name + for a in r.atoms: + a.chain = c.name + [self.atoms.extend(r.atoms) for r in c.residues] + + return 0 + + def PCA(self): + """Perform a principal component analysis on the atom coordinates. Returns eigenvals and eigenvecs. Sorted from largest to smallest eigenvalue""" + + M = array([a.coords for a in self.atoms]) + # covariance matrix + covmat = cov(M,rowvar=0) + + # find the eigenvalues and eigenvecs + (eval,evec) = linalg.eig(covmat) + + # sort eval and evec + ind = argsort(-eval) + eval = eval[ind] + evec = evec[:,ind] + + # make sure it forms a right-handed coordinate system + check = dot(cross(evec[:,0],evec[:,1]),evec[:,2]) + + if (check < 0): + ind = [1,0,2] + evec = evec[:,ind] + + return (eval,evec) + + def rotateM(self,M): + """Rotate entire structure by the given rotation matrix""" + + rotmat = matrix(M).T + for a in self.atoms: + a.coords = array(a.coords*rotmat)[0] + + def atomByBum(self,num): + # get the atom of the given number + for a in self.atoms: + if a.num == num: + return a + return None + + def chainByName(self,name): + # get the first chain with the given name + + for c in self.chains: + if c.name==name: + return c + + def initvars(self): + """Initialize various variables""" + + # extra lines at start/end of structure + self.startlines = [] + self.endlines = [] + self.chains = [] + self.residues = [] + self.atoms = [] + + # transformations + self.transforms = [] + + def outputPDB(self,outfile,append=0,ident=1): + # output a pdb file for this structure + # if append then append to the pdb file + # ident is the model identifier to use + + if (append): + OF = open(outfile,'a') + else: + OF = open(outfile,'w') + + OF.write('MODEL %4d\n' %ident) + for l in self.startlines: + OF.write(l) + + if len(self.chains) == 0: + [OF.write(a.pdbline()) for a in self.atoms] + else: + # write in all the chain atoms + for c in self.chains: + for r in c.residues: + for a in r.atoms: + OF.write(a.pdbline()) + #if hasattr(c,'ter'): + # OF.write(c.ter) + + # write in all the extra atoms (not part of chains) + [OF.write(a.pdbline()) for a in self.atoms if a.chainobj == None] + + # write out any conect records + [OF.write(a.conline()) for a in self.atoms if len(a.conect) > 0] + + for l in self.endlines: + OF.write(l) + + OF.write('ENDMDL\n') + OF.close() + + def structFromFile(self,infile): + # given an input file, get structure based on the chains and residues found in that file + # WARNING: for now preserves only direct connectivity information + # no hydrogen bonds or salt bridges + + IF = open(infile) + lines = IF.readlines() + IF.close() + + self.transforms = [] + + started = 0 + for line in lines: + # check for symmetry transform lines + m = transformR.match(line) + if m != None: + tn = int(m.group(1)) + matrow = [float(m.group(i)) for i in range(2,5)] + shift = float(m.group(5)) + if tn > len(self.transforms): + self.transforms.append([[matrow],[shift]]) + else: + self.transforms[tn-1][0].append(matrow) + self.transforms[tn-1][1].append(shift) + self.startlines.append(line) + continue + + m = atomR.match(line) + #m2 = conectR.match(line) + if m == None: + if not started: + self.startlines.append(line) + elif line[:3] == 'TER': + newchain.ter = line + elif line[:6] =='CONECT': + # get the atom to which this record pertains + atm = self.atomByNum(int(line[6:11])) + if atm == None: + print "Cannot find atom number : ", int(line[6:11]) + else: + # get the atoms connected to it (max of 4) + for a in range(4): + str = line[11+5*a:16+5*a] + try: + atm.conect.append(self.atomByNum(int(str))) + except ValueError: + break + else: + self.endlines.append(line) + + continue + newatom = Atom(m) + if not started: + newres = Residue([newatom]) + newchain = Chain([newres]) + self.residues.append(newres) + self.chains.append(newchain) + started = 1 + else: + if newatom.resnum != self.atoms[-1].resnum: + newres = Residue([newatom]) + self.residues.append(newres) + if newatom.chain != self.atoms[-1].chain: + newchain = Chain([newres]) + if newatom.chain.strip() != '': + self.chains.append(newchain) + else: + newchain.residues.append(newres) + else: + newres.atoms.append(newatom) + + self.atoms.append(newatom) + if newatom.chain.strip() != '': + newatom.chainobj = newchain + newatom.resobj = newres + + self.endlines = [] + + for t in self.transforms: + t[0] = array(t[0]); t[1] = array(t[1]) + + def renumAtoms(self,start=1): + """Renumber all atoms from 1 or another starting point""" + for i in range(len(self.atoms)): + self.atoms[i].num = start + i + + def atomByNum(self,num): + """Get the atom with the corresponding number""" + for a in self.atoms: + if a.num == num: + return a + return None + + def getCOM(self,countHet=0): + """Get the center of mass of all the atoms in the structure. If countHet is true, include heteroatoms as well""" + + if countHet: + alist = self.atoms + else: + alist = [a for a in self.atoms if a.type == 'ATOM'] + + com = [0,0,0] + for i in range(3): + com[i] = sum([a.coords[i] for a in alist])/float(len(alist)) + + return com + + def recenter(self): + """Move entire structure to shift COM to 0""" + com = self.getCOM(countHet=1) # center of mass of whole thing + # shift everything by center of mass + for a in self.atoms: + a.coords = a.coords - com + +def makeBareStruct(): + """Make a barebones structure with nothing in it, but containing appropriate start/end stuff so that it can be output to pdb""" + + struct = Structure() + #struct.startlines = ['HET SSN A 1 1402 Pseudo atom representation of DNA\n', \ + # 'HETNAM SSN Body and ribbon spatial coordinates\n',\ + # 'FORMUL 1 SSN C20 N20 P21\n'] + struct.startlines = ['HEADER structure\n'] + struct.endlines = ['END\n'] + + return struct diff --git a/BasicWLC/dssWLC/scripts/pdbutils.pyc b/BasicWLC/dssWLC/scripts/pdbutils.pyc new file mode 100644 index 00000000..02d686b4 Binary files /dev/null and b/BasicWLC/dssWLC/scripts/pdbutils.pyc differ diff --git a/BasicWLC/dssWLC/scripts/snapshot2pdb.py b/BasicWLC/dssWLC/scripts/snapshot2pdb.py new file mode 100644 index 00000000..cad58cd0 --- /dev/null +++ b/BasicWLC/dssWLC/scripts/snapshot2pdb.py @@ -0,0 +1,165 @@ +#!/usr/bin/python + +# convert an output file of snapshots to a pdb with multiple structures + +from pdbutils import * +import sys, os + +def lines2Struct(lines,branchscl=0.1,scl=10): + """Parse lines containing info on chain bead position and orientation. Connect atoms appropriately. Return structure. All coordinates are scaled by scl.""" + + beads = []; uvec = []; obstacles=[] + chainnum = 0; newchain = 1; + + # use occupancies and b factors to track the weight of each bead + # based on integrated r and u + # given in the last 2 columns of the snapshot file + occupancies = [] + bfactors = [] + for line in lines: + data = line.split() + if data[0]=='C': # new chain + chainnum += 1 + newchain = 1 + continue + + coords = [float(x)*scl for x in data[1:7]] + + if (data[0] != 'A'): + print 'Bad line, skipping:', line + else: + + crd = coords[:3] + atm = Atom(coords=crd,name=data[0]) + if (len(data)>13): + tmp = [float(data[13]),float(data[14])] + if (tmp[0]>0): + atm.occupancy = -log(tmp[0]) + if (tmp[1]>0): + atm.bfactor = -log(tmp[1]) +# occupancies.append(float(data[13])) +# bfactors.append(float(data[14])) + + beads.append(atm) + beads[-1].chain = "%d"%chainnum + if (not newchain): + beads[-2].conect.append(beads[-1]) + beads[-1].conect.append(beads[-2]) + + # orientation vector atoms + ucrd = list(array(crd) + array(coords[3:])*branchscl) + uvec.append(Atom(coords=ucrd,name=data[0]+'U')) + uvec[-1].conect.append(beads[-1]) + beads[-1].conect.append(uvec[-1]) + + newchain = 0 + + #if len(occupancies)>0: + # occ = [x for x in occupancies if x>0] + # if (len(occ)>0): + # minocc= min(occ) + # for c in range(len(beads)): + # beads[c].occupancy = occupancies[c]/minocc + + # bfact = [x for x in bfactors if x>0] + # if (len(bfact)>0): + # minbfact= min(bfact) + # for c in range(len(beads)): + # beads[c].bfactor = bfactors[c]/minbfact + + struct = makeBareStruct() + struct.endlines=[] +# struct.startlines = ['HEADER struct\n'] + struct.startlines = [] + struct.atoms.extend(beads) + struct.atoms.extend(uvec) + struct.atoms.extend(obstacles) + struct.renumAtoms() + + return struct + +def runcode(argv): + if len(argv) < 2: + print """ +usage: beadobst2pdb.py infile(s) -o +All argument pairs besides the input file are optional. Can also supply a list or glob (eg: file.*.out) of input files. Input files may not start with "-" +-o Gives the output pdb file name. Default output file is: infileroot.pdb +-scl is the scaling factor to convert from .out to .pdb coordinates + (default 10, as the .out file is expected to be in nm while the .pdb file is in angstroms) +-branchscl is the factor for scaling branch lengths. Default is 0.1 +-skip # skip the first few snapshots +""" + sys.exit() + + # parse input arguments + infile = sys.argv[1] + + if '-o' in argv: + ind = argv.index('-o') + outfile = argv[ind+1] + else: + outfile = infile + (root,ext) = os.path.splitext(infile) + outfile = root+'.pdb' + + if '-branchscl' in argv: + ind = argv.index('-branchscl') + branchscl = float(argv[ind+1]) + else: + branchscl = 0.1 + + if '-scl' in argv: + ind = argv.index('-scl') + scl = float(argv[ind+1]) + else: + scl = 10 + + if '-skip' in argv: + ind = argv.index('-skip') + skip = int(argv[ind+1]) + print "Skipping first %d snapshots" %skip + else: + skip = 0 + + #read in file and get structures + structs = [] + IF = open(infile) + lines = IF.readlines() + infolines = [c for c in range(len(lines)) if lines[c][0]=='I'] + starting = 1; + for c in range(skip,len(infolines)): + data = lines[infolines[c]].split() + nbead = int(data[1]) + + start = infolines[c]+1 + if c==len(infolines)-1: + end = len(lines) + else: + end = infolines[c+1] + + beadlines = lines[start:end] +# if len(beadlines) != nbead: +# print 'Inappropriate number of beads. Skipping struct', c +# else: + + print 'Structure %d, with %d chains. %d total atoms.' %(c,nbead,len(beadlines)) + + struct = lines2Struct(beadlines,branchscl,scl) + append = not (starting) + starting = 0 + + struct.outputPDB(outfile,append,c+1) + #structs.append(st) + + IF.close() + + # for cf in range(len(infiles)): + # infile = infiles[cf]; outfile = outfiles[cf] + # print "Input file, output file:", infile, outfile + + # struct = coordFile2Struct(infile,branchscl,scl) + # struct.outputPDB(outfile) + +if __name__ == '__main__': + runcode(sys.argv) + diff --git a/BasicWLC/dssWLC/scripts/viewsnapshots.pml b/BasicWLC/dssWLC/scripts/viewsnapshots.pml new file mode 100644 index 00000000..1c4c5488 --- /dev/null +++ b/BasicWLC/dssWLC/scripts/viewsnapshots.pml @@ -0,0 +1,12 @@ +hide all +select beads, name A +spectrum count, rainbow, beads +alter beads, vdw=0.5 +show spheres, beads +show sticks, beads +set sphere_transparency=0.4, beads +set sphere_scale=0.1 +set stick_radius=0.01 + +select uvec, name AU +#show sticks, uvec \ No newline at end of file diff --git a/BasicWLC/dssWLC/shearableWLC.exe b/BasicWLC/dssWLC/shearableWLC.exe new file mode 100644 index 00000000..fd7b2aa9 Binary files /dev/null and b/BasicWLC/dssWLC/shearableWLC.exe differ diff --git a/BasicWLC/dssWLC/source/Makefile b/BasicWLC/dssWLC/source/Makefile new file mode 100644 index 00000000..ac0342b2 --- /dev/null +++ b/BasicWLC/dssWLC/source/Makefile @@ -0,0 +1,42 @@ +OBJS = chainutil.o quatutil.o keys.o readkey.o genutil.o mt19937.o inputparams.o montecarlo.o inpututil.o browndyn.o redisc.o cylinder.o dbrent.o nrtype.o nrutils.o manychains.o dgtsl.o sampleutil.o besselI0.o + +FC = gfortran +FLAGS = -O3 +DEBUGFLAGS = +LIBS = -lblas -llapack + +# executable name +EXE = ../shearableWLC.exe +TESTEXE = ../testrun.exe + +.SUFFIXES: .o .f90 + +# general suffix rules +%.o: %.f90 + $(FC) $(FLAGS) $(DEBUGFLAGS) -c $< + +default: $(OBJS) main.o + $(FC) $(FLAGS) $(DEBUGFLAGS) $(OBJS) main.o -o $(EXE) $(LIBS) + +test: $(OBJS) testmain.o + $(FC) $(FLAGS) $(DEBUGFLAGS) $(OBJS) testmain.o -o $(TESTEXE) $(LIBS) + +clean: + rm *.o *.mod + +veryclean: clean + rm *~ $(EXE) + +# ------------ +# individual file dependencies +# ------------ +chainutil.o: keys.o quatutil.o mt19937.o genutil.o +readkey.o: inputparams.o keys.o genutil.o mt19937.o +genutil.o: mt19937.o quatutil.o +browndyn.o: chainutil.o genutil.o dgtsl.o +redisc.o: chainutil.o cylinder.o +cylinder.o: dbrent.o +dbrent.o: nrtype.o nrutils.o +montecarlo.o: chainutil.o redisc.o manychains.o browndyn.o +manychains.o: chainutil.o +sampleutil.o: dbrent.o besselI0.o \ No newline at end of file diff --git a/BasicWLC/dssWLC/source/a0boundfunc.f90 b/BasicWLC/dssWLC/source/a0boundfunc.f90 new file mode 100644 index 00000000..85d8d6d1 --- /dev/null +++ b/BasicWLC/dssWLC/source/a0boundfunc.f90 @@ -0,0 +1,27 @@ +SUBROUTINE A0BOUNDFUNC(R,PARAM,FU,DU) +! function used to find enveloping Lorentzian for cylindrical gaussian +! PARAM is array of parameters (A,B,R0,M0) +! FU returns function values, DU returns derivative +! sign flipped upside down to do minimization rather than maximization + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: R, PARAM(4) + DOUBLE PRECISION, INTENT(OUT) :: FU, DU + DOUBLE PRECISION :: A, B, R0, M0 + + PRINT*, 'TESTX0:', PARAM + A = PARAM(1); B = PARAM(2); R0 = PARAM(3); M0 = PARAM(4) + + IF (ABS(R-R0).LT.1D-15) THEN + ! use asymptotic form near r0 + DU = (-B+SQRT(2/A+B**2))/(6+3*A*B**2) + FU = 1 + B*SQRT(A/(2+A*B**2))/(2*A) + DU*(R-R0) + ELSE + FU = R*(R-R0)**2/(M0*EXP(A*(R-B)**2) - R) + DU = (R-R0)*(-2*R**2-EXP(A*(B-R)**2)*M0*(R*(-3-2*A*(B-R)*(R-R0))+R0)) / & + & (R-M0*EXP(A*(B-R)**2))**2 + END IF + + FU = -FU; DU = -DU; + + PRINT*, 'TESTX1:', R, PARAM, FU, DU +END SUBROUTINE A0BOUNDFUNC diff --git a/BasicWLC/dssWLC/source/besselI0.f90 b/BasicWLC/dssWLC/source/besselI0.f90 new file mode 100644 index 00000000..5113a67f --- /dev/null +++ b/BasicWLC/dssWLC/source/besselI0.f90 @@ -0,0 +1,82 @@ +SUBROUTINE Bessf_I0(x, Bess_I0) +! -------------------------------------------- +! EFK: copied from bessfin.f90 +! downloaded from: http://www.netlib.org/a/sf/bessfin.f90 +! -------------------------------------------- +! +! Subroutine Program: Bessf_I0.f90 +! FN: Bessf_I0_ver1 Created: november 2001. +! +! Version 1; Brian Geelen. +! +! Purpose: evaluation of the modifed Bessel function, I0(x), +! where x, is a positive real positive argument, over the interval 1 to 100. +! +! Accuracy: returns precision of at least 9 significant decimal places. +! +! Convergent power series solution for x < 14, asymptotic series for x > 14. +! +! +! precision and variable declarations + + IMPLICIT NONE + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + REAL (KIND = i15) :: ak, px, an, series_delta, series_rslt, & + odd, seq_num, ser_num, fact, b1, b2, b3 + + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + INTEGER (KIND = i9) :: loop_1, loop_2 + + REAL (KIND = i15), PARAMETER :: e = 2.718281828459045D0, & + pi = 3.141592653589793D0, error = 0.5D-12 + + REAL (KIND = i15), INTENT(IN) :: x + REAL (KIND = i15), INTENT(OUT) :: Bess_I0 + +! select power series or asympotic series solution + + expression_select: IF (x < 14.0) THEN ! power series for x < 14 + + ak = 0.0D0; an = 1.0D0; series_rslt = 0.0D0 ! set variables + + series_solution: DO loop_1 = 1, 50 + + ak = ak + 2.0D0 + px = x **(ak) + an = an * (ak * ak) + series_delta = (px / an) + series_rslt = series_rslt + (px / an) + Bess_I0 = 1.0D0 + series_rslt + + IF (series_delta < error) EXIT ! exit if error term satisfied + + END DO series_solution + + ELSE ! asymptotic series solution for x > 14 + + odd = 1.0D0; seq_num = 1.0D0; ser_num = 1.0D0 ! set variables + fact = 2.0D0; an = 2.0D0 + + b1 = (e **x) / DSQRT(2.0D0 * pi * x) + b2 = 8.0D0 * x + series_rslt = 1.0D0 + (1.0D0 / b2) + (9.0D0 / (2.0D0 * (b2**2.0D0) ) ) + + asymptotic_series: DO loop_2 = 1,20 + + odd = odd + 2.0D0 + seq_num = seq_num * (odd** 2.0D0) + ser_num = seq_num * ( (odd + 2.0D0) **2.0D0) + + an = an + 1.0D0 + fact = fact * an + b3 = (8.0D0 * x) **an + + series_delta = (ser_num / (fact * b3) ) + series_rslt = series_rslt + (ser_num / (fact * b3) ) + Bess_I0 = b1 * series_rslt + + END DO asymptotic_series + + END IF expression_select + + END SUBROUTINE Bessf_I0 diff --git a/BasicWLC/dssWLC/source/bessfin.f90 b/BasicWLC/dssWLC/source/bessfin.f90 new file mode 100644 index 00000000..64080aba --- /dev/null +++ b/BasicWLC/dssWLC/source/bessfin.f90 @@ -0,0 +1,342 @@ +! Program: Example Inx.f90 +! +! Brian Geelen. Created: november 2001. +! +! Example use of Module Bessf_In_x +! + PROGRAM example_Inx + + USE Bessf_In_x + + IMPLICIT NONE + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + REAL (KIND = i15) :: x, Bess_In + + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + INTEGER (KIND = i9) :: n, loop_1 + + n = -1 + x = 1.0D0 + + + DO loop_1 = 1, 21 + + n = n + 1 + + CALL Bessf_In(x, n, Bess_In) + + + WRITE(*,100)x, n, Bess_In + 100 FORMAT(2x, F5.1, 4x, I3, 4x, ES16.9) + + END DO + + STOP + END PROGRAM example_Inx + + + MODULE Bessf_In_x +! +! Module Program: Bessf_In.f90 +! FN: Bessf_In Version 1; Created: november 2001. +! +! Purpose: evaluation of the modifed Bessel function of the first kind, +! In(x), where n, an integer value, over the interval 0 to 100, and +! x, is a real positive argument, over the interval 1 to 100. Calculation +! procedure is based on convergent power series and asymptotic series. +! +! Accuracy: returns precision of at least 9 significant decimal places. +! +! Reference: Geelen, B., "Accurate solution for the modified Bessel +! function of the first kind", Advances in Engineering Software, No 23, +! 1995, pp. 105-109. +! +! Uses apart subroutines for I0(x), I1(x) and In(x) where n = or > 2. +! +! Brian Geelen; PB10416, 6000GK Weert, The Netherlands. Email: bwave@iae.nl +! +! Example output result listing: +! x n In(x) +! 1.0 0 1.266065878E+00 +! 1.0 1 5.651591040E-01 +! 1.0 2 1.357476698E-01 +! 1.0 3 2.216842492E-02 +! 1.0 20 3.966835986E-25 +! 1.0 100 8.473674008E-189 +! +!*** +!*** +!*** +! + IMPLICIT NONE + PRIVATE + PUBLIC :: Bessf_In + CONTAINS + + SUBROUTINE Bessf_In(x, n, Bess_In) + + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + + REAL (KIND = i15), INTENT(IN) :: x + REAL (KIND = i15), INTENT(OUT) :: Bess_In + INTEGER (KIND = i9), INTENT(IN) :: n + + IF (n < 1) THEN + + CALL Bessf_I0(x, Bess_In) + + ELSEIF( n < 2) THEN + + CALL Bessf_I1(x, Bess_In) + + ELSE + + CALL Bessf_In_gt2(x, n, Bess_In) + + ENDIF + + END SUBROUTINE Bessf_In +!*** +!****************************************************************************** +!*** + SUBROUTINE Bessf_I0(x, Bess_I0) +! +! Subroutine Program: Bessf_I0.f90 +! FN: Bessf_I0_ver1 Created: november 2001. +! +! Version 1; Brian Geelen. +! +! Purpose: evaluation of the modifed Bessel function, I0(x), +! where x, is a positive real positive argument, over the interval 1 to 100. +! +! Accuracy: returns precision of at least 9 significant decimal places. +! +! Convergent power series solution for x < 14, asymptotic series for x > 14. +! +! +! precision and variable declarations + + IMPLICIT NONE + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + REAL (KIND = i15) :: ak, px, an, series_delta, series_rslt, & + odd, seq_num, ser_num, fact, b1, b2, b3 + + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + INTEGER (KIND = i9) :: loop_1, loop_2 + + REAL (KIND = i15), PARAMETER :: e = 2.718281828459045D0, & + pi = 3.141592653589793D0, error = 0.5D-12 + + REAL (KIND = i15), INTENT(IN) :: x + REAL (KIND = i15), INTENT(OUT) :: Bess_I0 + +! select power series or asympotic series solution + + expression_select: IF (x < 14.0) THEN ! power series for x < 14 + + ak = 0.0D0; an = 1.0D0; series_rslt = 0.0D0 ! set variables + + series_solution: DO loop_1 = 1, 50 + + ak = ak + 2.0D0 + px = x **(ak) + an = an * (ak * ak) + series_delta = (px / an) + series_rslt = series_rslt + (px / an) + Bess_I0 = 1.0D0 + series_rslt + + IF (series_delta < error) EXIT ! exit if error term satisfied + + END DO series_solution + + ELSE ! asymptotic series solution for x > 14 + + odd = 1.0D0; seq_num = 1.0D0; ser_num = 1.0D0 ! set variables + fact = 2.0D0; an = 2.0D0 + + b1 = (e **x) / DSQRT(2.0D0 * pi * x) + b2 = 8.0D0 * x + series_rslt = 1.0D0 + (1.0D0 / b2) + (9.0D0 / (2.0D0 * (b2**2.0D0) ) ) + + asymptotic_series: DO loop_2 = 1,20 + + odd = odd + 2.0D0 + seq_num = seq_num * (odd** 2.0D0) + ser_num = seq_num * ( (odd + 2.0D0) **2.0D0) + + an = an + 1.0D0 + fact = fact * an + b3 = (8.0D0 * x) **an + + series_delta = (ser_num / (fact * b3) ) + series_rslt = series_rslt + (ser_num / (fact * b3) ) + Bess_I0 = b1 * series_rslt + + END DO asymptotic_series + + END IF expression_select + + END SUBROUTINE Bessf_I0 +!*** +!****************************************************************************** +!*** + SUBROUTINE Bessf_I1(x, Bess_I1) +! +! Subroutine Program: Bessf_I1 +! FN: Bessf_I1_ver1.f90 Created: november 2001. +! +! Version 1; Brian Geelen. +! +! Purpose: evaluation of the modified Bessel function, I1(x), +! where x, is a real positive argument, over the interval 1 to 100 +! +! Accuracy: returns precision of at least 9 significant decimal places. +! +! Convergent power series solution for x < 14, asymptotic series for x > 14. +! +! +! precision and variable declarations + + IMPLICIT NONE + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + REAL (KIND = i15) :: ak, an, fact1, sx, a2, fact2, series_delta, & + odd, seq_num, ser_num, c1, c2, c3, series + + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + INTEGER (KIND = i9) :: loop_1, loop_2 + + REAL (KIND = i15), PARAMETER :: e = 2.718281828459045D0, & + pi = 3.141592653589793D0, error = 0.5D-12 + + REAL (KIND = i15), INTENT(IN) :: x + REAL (KIND = i15), INTENT(OUT) :: Bess_I1 + +! select power series or asympotic series solution + + expression_select: IF (x < 14.0) THEN ! power series solution for x < 14 + + ak = 1.0D0; an = 0.0D0; fact1 = 1.0D0 ! set variables + + Bess_I1 = (x / 2.0D0) + + series_solution: DO loop_1 = 1,31 + + ak = ak + 2.0D0 + sx = x **(ak) + + a2 = 2.0D0**(ak) + + an = an + 1.0D0 + fact1 = fact1 * an + fact2 = fact1 * (an + 1.0D0) + + Bess_I1 = ( sx / (a2 * fact1 * fact2 ) ) + Bess_I1 + series_delta = ( sx / (a2 * fact1 * fact2 ) ) + + IF (series_delta < error) EXIT ! exit if error term satisfied + + END DO series_solution + + ELSE ! asymptotic series solution for x > 14 + + odd = 1.0D0; seq_num = 1.0D0; ser_num = 1.0D0 ! set variables + an = 2.0D0; fact1 = 2.0D0 + + c1 = (e **x) / DSQRT(2.0D0 * pi * x) + c2 = 8.0D0 * x + series = 1.0D0 - (3.0D0 / c2) - (15.0D0 / (2.0D0 * (c2**2.0D0) )) + + asymptotic_series: DO loop_2 = 1,29 + + odd = odd + 2.0D0 + seq_num = (odd * odd) * seq_num + ser_num = seq_num * (odd + 2.0D0) * (odd + 4.0D0) + + an = an + 1.0D0 + fact1 = fact1 * an + + c3 = (8.0D0 * x) **an + series = series - ( ser_num / ( fact1 * c3 )) + + Bess_I1 = series * c1 + + END DO asymptotic_series + + END IF expression_select + + END SUBROUTINE Bessf_I1 +!*** +!****************************************************************************** +!*** + Subroutine Bessf_In_gt2(x, n, Bess_In) +! +! Subroutine Program: Bessf_In.f90 +! FN: Bessf_In_GT2_ver1 Created: november 2001. +! +! Version 1; Brian Geelen. +! +! Purpose: evaluation of the modifed Bessel function, In(x), +! where n, a integer value, is = or > 2, and x, a positive real +! argument, over the interval 1 to 100. +! +! Accuracy: returns precision of at least 9 significant decimal places. +! +! Employs a downward recurrence approach with nornmalisation to I0(x). +! External call made to subroutine Bessf_I0 +! to solve the modifed Bessel function I0(x). +! +! +! precision and variable declarations + + IMPLICIT NONE + INTEGER, PARAMETER :: i15 = SELECTED_REAL_KIND(15,300) + REAL (KIND = i15) :: a1, a2, a3, a4, Bess_I0 + + INTEGER, PARAMETER :: i9 = SELECTED_INT_KIND(9) + INTEGER (KIND = i9) :: j1, m, k, iexp + + REAL (KIND = i15), INTENT(IN) :: x + REAL (KIND = i15), INTENT(OUT) :: Bess_In + + INTEGER (KIND = i9), INTENT(IN) :: n + + iexp = maxexponent(x)/2 ! initialisation parameter + + + a1 = 1.0D0; a2 = 0.0D0; a3 = 2.0D0 / x + Bess_In = 0.0D0 + + j1 = 200 + + m = 2 * ( (n + INT (SQRT (real (j1 * n)) ))) + + recursion: DO k = m, 1, -1 ! perform downward recursion + + a4 = a2 + k * a1 * a3 + a2 = a1 + a1 = a4 + + IF (exponent(a1) > iexp) THEN + + Bess_In = scale(Bess_In, -iexp) + a1 = scale(a1, -iexp) + a2 = scale(a2, -iexp) + + END IF + IF (k == n) Bess_In = a2 + + END DO recursion + +! solve Bessel function I0(x) with subroutine call +! and perform normalisation to I0(x) + + CALL Bessf_I0(x, Bess_I0) + + Bess_In = Bess_In * Bess_I0 / a1 + + END Subroutine Bessf_In_gt2 +!*** +!****************************************************************************** +!*** +END MODULE Bessf_In_x diff --git a/BasicWLC/dssWLC/source/browndyn.f90 b/BasicWLC/dssWLC/source/browndyn.f90 new file mode 100644 index 00000000..c3a97af3 --- /dev/null +++ b/BasicWLC/dssWLC/source/browndyn.f90 @@ -0,0 +1,1109 @@ +MODULE BROWNDYN + USE GENUTIL + ! utilities for running BD simulations with the chain + IMPLICIT NONE + ! extra printing for this chain + INTEGER :: VERBOSECHAIN = 18160 + LOGICAL :: VERBOSE = .FALSE. + +CONTAINS + SUBROUTINE RUNBROWNDYN(CHAINLIST,NCHAIN,NSTEP,DELT,KT,OUTFILE,RUNGEKUTTA,DOBROWN) + ! run brownian dynamics for NSTEP steps for a bunch of chains in parallel + ! using time step DELT and temperature KT + ! Periodically print out energy and end-to-end vector for all chains + ! RUNGEKUTTA = 1 for euler method or 4 for 4-th order runge-kutta + ! if DOBROWN=false, do not include brownian forces + USE CHAINUTIL, ONLY : CHAIN, OUTPUTSNAPSHOT, RESETLINKERS + USE KEYS,ONLY: BDPRINTEVERY, BDPRINTLOG, STRESSFILE, SNAPSHOTFILE, & + & SNAPSHOTEVERY, DUMPSNAPSHOTS, BRCRELAX, LOOPRAD, TRACKLOOPING, LOOPFILE + IMPLICIT NONE + INTEGER, INTENT(IN) :: NCHAIN, NSTEP + DOUBLE PRECISION, INTENT(IN) :: DELT, KT + CHARACTER(LEN=*) :: OUTFILE + INTEGER, INTENT(IN) :: RUNGEKUTTA + LOGICAL :: DOBROWN + TYPE(CHAIN), INTENT(IN),TARGET :: CHAINLIST(NCHAIN) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: STEP, C, B + DOUBLE PRECISION :: DR(3), ENERGY, COM(3), MEANSTRESSCORR, STDSTRESSCORR + DOUBLE PRECISION :: STRESSXY(6), STRESSXY0(NCHAIN,6),STRESSCORR(NCHAIN) + INTEGER :: NEXTPRINT + LOGICAL :: START(nchain), FIRSTSNAP, reset, DONELOOP(NCHAIN) + DOUBLE PRECISION, ALLOCATABLE :: TMPARRAY(:,:),TMPARRAY2(:,:) + DOUBLE PRECISION :: LOOPRAD2 + + allocate(TMPARRAY(3,CHAINLIST(1)%NPT), TMPARRAY2(3,CHAINLIST(1)%NPT)) + + PRINT*, 'Running BD simulation with ', NCHAIN, 'chains, for ', NSTEP, 'steps' + START = .TRUE. + FIRSTSNAP = .TRUE. + + IF (BDPRINTLOG) THEN + NEXTPRINT = 1 + ENDIF + + OPEN(88,FILE=STRESSFILE,STATUS='UNKNOWN') + write(88,*) NCHAIN, DELT, KT, CHAINLIST(1)%NPT + + OPEN(55,FILE=OUTFILE,STATUS='UNKNOWN') + write(55,*) NCHAIN, DELT, KT + + OPEN(77,FILE=SNAPSHOTFILE,STATUS='UNKNOWN') + WRITE(77,*) 'X', NCHAIN,DELT,CHAINLIST(1)%NPT + CLOSE(77) + CHAINP=>CHAINLIST(1) + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,0,.true.) + + DONELOOP = .FALSE. + LOOPRAD2 = LOOPRAD*LOOPRAD + IF (TRACKLOOPING) THEN + OPEN(44,FILE=LOOPFILE,STATUS='UNKNOWN') + WRITE(44,*) NCHAIN, DELT, CHAINLIST(1)%NPT, LOOPRAD + ENDIF + + IF (TRACKLOOPING) THEN + DO C = 1,NCHAIN + CHAINP=>CHAINLIST(C) + DR = CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1) + IF (DR(1)*DR(1)+DR(2)*DR(2)+DR(3)*DR(3).LT.LOOPRAD2) THEN + print*, 'Chain ', C, ' has successfully looped at time ', 0 + WRITE(44,*) C,0,0D0, DR + FLUSH(44) + DONELOOP(C)=.TRUE. + ENDIF + ENDDO + ENDIF + + DO STEP=1,NSTEP + IF (ALL(DONELOOP)) THEN + PRINT*, 'ALL CHAINS HAVE LOOPED', STEP + EXIT + ENDIF + DO C = 1,NCHAIN + ! stop propagating this chain if it has already looped + IF (DONELOOP(C)) CYCLE + + CHAINP=>CHAINLIST(C) + + IF (.NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + !reset all linkers to ground-state + !this avoids numerical errors that push the lengths away from + !the desired values + CALL RESETLINKERS(CHAINP,0.005D0,RESET) + + !IF (RESET) PRINT*, 'resetting linker lengths:', STEP, C + ENDIF + + ! print*, 'testx1:', sqrt(sum((chainp%pos(:,2)-chainp%pos(:,1))**2)) + IF ((BDPRINTLOG.AND.STEP.EQ.NEXTPRINT).OR.& + & (.NOT.BDPRINTLOG.AND.MOD(STEP,NINT(BDPRINTEVERY)).EQ.0)) THEN + IF (RUNGEKUTTA.EQ.4) THEN + ! VERBOSE = C.EQ.VERBOSECHAIN + CALL LANGEVINSTEPRK4(CHAINP,DELT,ENERGY,DOBROWN,STRESSXY) + ! IF (VERBOSE) PRINT*, 'TESTX3:', ENERGY + ELSE IF (RUNGEKUTTA.EQ.1) THEN + CALL LANGEVINSTEP(CHAINP,DELT,KT,ENERGY,STRESSXY) + ELSE + PRINT*, 'RUNGEKUTTA must be 1 or 4', RUNGEKUTTA + stop 1 + END IF + + ! IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + ! CALL GETCHAINFORCEINT(CHAINP,TMPARRAY,TMPARRAY2,ENERGY,.FALSE.) + ! ELSE + ! CALL GETBEADRODFORCE(CHAINP,TMPARRAY,BRCRELAX,TMPARRAY2,ENERGY) + ! ENDIF + + ! IF (.NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + ! ! reset all linkers to groundstat + ! ! this avoids numerical errors that push the lengths away from + ! ! the desired values + ! CALL RESETLINKERS(CHAINP) + ! ENDIF + + DR = CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1) + COM(1) = SUM(CHAINP%POS(1,:)) + COM(2) = SUM(CHAINP%POS(2,:)) + COM(3) = SUM(CHAINP%POS(3,:)) + COM = COM/CHAINP%NPT + IF (START(C)) THEN + STRESSXY0(C,:) = STRESSXY + START(C) = .FALSE. + ENDIF + + STRESSCORR(c) = SUM(STRESSXY*STRESSXY0(C,:))/6 + ! if (stresscorr(c).gt.1000) then + ! print*, c,stresscorr(c) + ! do b = 1,chainp%npt + ! print*, chainp%pos(:,b) + ! enddo + ! print*, 'testx2' + ! do b = 1,chainp%npt + ! print*, chainp%uvec(:,b) + ! enddo + ! stop 1 + ! endif + !STRESSCORR(c) = STRESSXY(1)*STRESSXY0(C,1) + + + + IF (C.EQ.1) PRINT*, 'STEP, ENERGY:', STEP, ENERGY, DR + IF (.NOT.CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + CHAINP%UVEC(:,1) = CHAINP%POS(:,2)-CHAINP%POS(:,1) + IF (CHAINP%NPT.GE.3) THEN + COM = CHAINP%POS(:,3)-CHAINP%POS(:,2) + ENDIF + ENDIF + WRITE(55,*) STEP, C, ENERGY, DR, COM, CHAINP%UVEC(:,1)!,STRESSXY + FLUSH(55) + ELSE + IF (RUNGEKUTTA.EQ.4) THEN + CALL LANGEVINSTEPRK4(CHAINP,DELT,ENERGY,DOBROWN) + ELSE IF (RUNGEKUTTA.EQ.1) THEN + CALL LANGEVINSTEP(CHAINP,DELT,KT,ENERGY) + ELSE + PRINT*, 'RUNGEKUTTA must be 1 or 4', RUNGEKUTTA + stop 1 + END IF + ENDIF + + IF (TRACKLOOPING) THEN + DR = CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1) + IF (DR(1)*DR(1)+DR(2)*DR(2)+DR(3)*DR(3).LT.LOOPRAD2) THEN + print*, 'Chain ', C, ' has successfully looped at time ', STEP, STEP*DELT + WRITE(44,*) C,STEP, STEP*DELT, DR + FLUSH(44) + DONELOOP(C)=.TRUE. + ENDIF + ENDIF + + IF (DUMPSNAPSHOTS.AND.MOD(STEP,SNAPSHOTEVERY).EQ.0) THEN + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,STEP,.true.) + FIRSTSNAP=.FALSE. + !DO B = 1,CHAINP%NPT + ! WRITE(77,*) STEP, C, B, CHAINP%POS(:,B) + !ENDDO + ENDIF + + ENDDO + IF ((BDPRINTLOG.AND.STEP.EQ.NEXTPRINT).OR.& + & (.NOT.BDPRINTLOG.AND.MOD(STEP,NINT(BDPRINTEVERY)).EQ.0)) THEN + MEANSTRESSCORR = SUM(STRESSCORR)/NCHAIN + STDSTRESSCORR = SQRT(SUM((STRESSCORR-MEANSTRESSCORR)**2)/NCHAIN) + WRITE(88,*) STEP,MEANSTRESSCORR, STDSTRESSCORR + FLUSH(88) + END IF + IF (BDPRINTLOG.AND.STEP.EQ.NEXTPRINT) THEN + NEXTPRINT = CEILING(NEXTPRINT * EXP(BDPRINTEVERY*LOG(10D0))) + IF (NEXTPRINT.GT.NSTEP) NEXTPRINT = NSTEP + ENDIF + ENDDO + CLOSE(55) + CLOSE(88) + IF (TRACKLOOPING) CLOSE(44) + ! CLOSE(77) + + DEALLOCATE(TMPARRAY,TMPARRAY2) + END SUBROUTINE RUNBROWNDYN + + SUBROUTINE LANGEVINSTEPRK4(CHAINP,DELT,ENERGY,DOBROWN,STRESSXY) + ! propagate forward using a fourth-order Runge-Kutta method + + USE KEYS, ONLY : FIXBEAD1,FIXBEADMID,BRCRELAX + USE MT19937, ONLY : RNORM, grnd + USE CHAINUTIL, ONLY : CHAIN, OBSTACLE + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + TYPE(OBSTACLE), POINTER :: OBP + DOUBLE PRECISION, INTENT(IN) :: DELT + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + LOGICAL, INTENT(IN) :: DOBROWN + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: STRESSXY(6) + DOUBLE PRECISION :: POSFORCE(3,CHAINP%NPT), UFORCE(3,CHAINP%NPT) + DOUBLE PRECISION :: TENSBRFORCE(3,CHAINP%NPT) + DOUBLE PRECISION :: BROWNPOS(3,CHAINP%NPT), BROWNU(3,CHAINP%NPT) + INTEGER :: C,M, B, I, J,CT + DOUBLE PRECISION :: BROWNF, F, S2DTR(CHAINP%NPT), S2DTU(CHAINP%NPT), S2DTO, RHO, PHI,ST,CP,SP + DOUBLE PRECISION :: XVEC(3), YVEC(3), POS0(3,CHAINP%NPT),UVEC0(3,CHAINP%NPT) + DOUBLE PRECISION :: BROWNF1, BROWNF2, TORQUE(3), COM(3) + DOUBLE PRECISION, DIMENSION(3,CHAINP%NPT) :: K1POS,K1UVEC,K2POS,K2UVEC,K3POS,K3UVEC,K4POS,K4UVEC,POSFORCE0 + DOUBLE PRECISION :: CRELAX + + IF (FIXBEAD1.OR.FIXBEADMID) THEN + PRINT*, 'FIXBEAD1 AND FIXBEADMID not yet set up with runge kutta', FIXBEAD1, FIXBEADMID + STOP 1 + ENDIF + + ! coefficient for the additional force to keep bond lengths constrained + IF (.NOT.CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + CRELAX = MINVAL(CHAINP%FRICTR(1:CHAINP%NPT))*BRCRELAX/DELT + ENDIF + + S2DTR = SQRT(2*CHAINP%FRICTR(1:CHAINP%NPT)/DELT) + S2DTU = SQRT(2*CHAINP%FRICTU(1:CHAINP%NPT)/DELT) + + POS0 = CHAINP%POS; UVEC0 = CHAINP%UVEC + IF (PRESENT(STRESSXY)) THEN + STRESSXY = 0D0 + ENDIF + + IF (DOBROWN) THEN + ! get the brownian forces + BROWNU = 0D0; BROWNPOS = 0D0 + + DO B = 1,CHAINP%NPT + ! translational brownian force + BROWNPOS(1,B) = RNORM()*S2DTR(B) + BROWNPOS(2,B) = RNORM()*S2DTR(B) + BROWNPOS(3,B) = RNORM()*S2DTR(B) + + IF (CHAINP%SHEARABLE) THEN + ! rotational brownian force + BROWNF1 = RNORM()*S2DTU(B) + BROWNF2 = RNORM()*S2DTU(B) + IF (CHAINP%UVEC(2,B).EQ.0D0.AND.CHAINP%UVEC(3,B).EQ.0D0) THEN + XVEC = (/0D0,1D0,0D0/) + YVEC = (/0D0,0D0,1D0/) + ELSE + CALL CROSS_PRODUCT(CHAINP%UVEC(:,B),(/1D0,0D0,0D0/),XVEC) + CALL CROSS_PRODUCT(CHAINP%UVEC(:,B),XVEC,YVEC) + ENDIF + BROWNU(:,B) = BROWNF1*XVEC + BROWNF2*YVEC + ENDIF + ENDDO + ELSE + BROWNPOS = 0D0; BROWNU = 0D0; + ENDIF + + + ! OPEN(UNIT=44,FILE='brownpos.out') + ! DO B = 1,CHAINP%NPT + ! WRITE(44,*) BROWNPOS(:,B) + ! ENDDO + ! close(44) + + ! --------- 1ST RK STEP--------------- + + ! Get the deterministic forces + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.TRUE.) + ! IF (VERBOSE) THEN + ! PRINT*, 'TESTX4:' + ! DO B = 1,CHAINP%NPT + ! PRINT*, B, POSFORCE(:,B) + ! ENDDO + ! ENDIF + ELSE + ! also project out the components of the brownian force + ! that would change segment lengths +! print*, 'testx2:', brownpos(:,5), s2dtr + CALL GETBEADRODFORCE(CHAINP,BROWNPOS,CRELAX,POSFORCE,ENERGY,.true.) + ENDIF + + IF (CHAINP%SHEARABLE) THEN + ! Get just the perpendicular component of the U forces + DO B = 1,CHAINP%NPT + UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + CALL CROSS_PRODUCT(UVEC0(:,B),UFORCE(:,B),TORQUE) + CALL CROSS_PRODUCT(TORQUE,UVEC0(:,B),UFORCE(:,B)) + K1UVEC(:,B) = (BROWNU(:,B) + UFORCE(:,B))/CHAINP%FRICTU(B) + ENDDO + ENDIF + + DO B = 1,CHAINP%NPT + K1POS(:,B) = (BROWNPOS(:,B) + POSFORCE(:,B))/CHAINP%FRICTR(B) + ENDDO + + POSFORCE0 = POSFORCE; + + + ! propagate forward + CHAINP%POS = POS0 + DELT/2*K1POS + +! print*, 'testx1:', chainp%pos(:,3) + IF (CHAINP%SHEARABLE) THEN + CHAINP%UVEC = UVEC0 + DELT/2*K1UVEC + ! renormalize UVECs + DO B = 1,CHAINP%NPT + CALL NORMALIZE(CHAINP%UVEC(:,B)) + ENDDO + ENDIF + + ! print*, 'testx5:' + ! do b = 1,chainp%npt + ! print*, b, chainp%pos(:,b) + ! enddo + ! stop 1 + !--------- 2ND RK STEP-------------- + ! Get the deterministic forces + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.TRUE.) + ELSE + CALL GETBEADRODFORCE(CHAINP,BROWNPOS,CRELAX,POSFORCE,ENERGY,.FALSE.) + ENDIF + + IF (CHAINP%SHEARABLE) THEN + ! Get just the perpendicular component of the U forces + DO B = 1,CHAINP%NPT + UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + CALL CROSS_PRODUCT(UVEC0(:,B),UFORCE(:,B),TORQUE) + CALL CROSS_PRODUCT(TORQUE,UVEC0(:,B),UFORCE(:,B)) + K2UVEC(:,B) = (BROWNU(:,B) + UFORCE(:,B))/CHAINP%FRICTU(B) + ENDDO + ENDIF + + DO B = 1,CHAINP%NPT + K2POS(:,B) = (BROWNPOS(:,B) + POSFORCE(:,B))/CHAINP%FRICTR(B) + ENDDO + + ! propagate forward + CHAINP%POS = POS0 + DELT/2*K2POS + IF (CHAINP%SHEARABLE) THEN + CHAINP%UVEC = UVEC0 + DELT/2*K2UVEC + ! renormalize UVECs + DO B = 1,CHAINP%NPT + CALL NORMALIZE(CHAINP%UVEC(:,B)) + ENDDO + ENDIF + + ! --------- 3RD RK STEP----------------- + ! Get the deterministic forces + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.TRUE.) + ELSE + CALL GETBEADRODFORCE(CHAINP,BROWNPOS,CRELAX,POSFORCE,ENERGY,.FALSE.) + ENDIF + + IF (CHAINP%SHEARABLE) THEN + ! Get just the perpendicular component of the U forces + DO B = 1,CHAINP%NPT + UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + CALL CROSS_PRODUCT(UVEC0(:,B),UFORCE(:,B),TORQUE) + CALL CROSS_PRODUCT(TORQUE,UVEC0(:,B),UFORCE(:,B)) + K3UVEC(:,B) = (BROWNU(:,B) + UFORCE(:,B))/CHAINP%FRICTU(B) + ENDDO + ENDIF + + DO B = 1,CHAINP%NPT + K3POS(:,B) = (BROWNPOS(:,B) + POSFORCE(:,B))/CHAINP%FRICTR(B) + ENDDO + + + ! propagate forward + CHAINP%POS = POS0 + DELT*K3POS + IF (CHAINP%SHEARABLE) THEN + CHAINP%UVEC = UVEC0 + DELT*K3UVEC + ! renormalize UVECs + DO B = 1,CHAINP%NPT + CALL NORMALIZE(CHAINP%UVEC(:,B)) + ENDDO + ENDIF + + + ! ---------- 4TH RK STEP------------------ + ! Get the deterministic forces + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.TRUE.) + ELSE + CALL GETBEADRODFORCE(CHAINP,BROWNPOS,CRELAX,POSFORCE,ENERGY,.FALSE.) + ENDIF + + IF (CHAINP%SHEARABLE) THEN + ! Get just the perpendicular component of the U forces + DO B = 1,CHAINP%NPT + UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + CALL CROSS_PRODUCT(UVEC0(:,B),UFORCE(:,B),TORQUE) + CALL CROSS_PRODUCT(TORQUE,UVEC0(:,B),UFORCE(:,B)) + K4UVEC(:,B) = (BROWNU(:,B) + UFORCE(:,B))/CHAINP%FRICTU(B) + ENDDO + ENDIF + + DO B = 1,CHAINP%NPT + K4POS(:,B) = (BROWNPOS(:,B) + POSFORCE(:,B))/CHAINP%FRICTR(B) + ENDDO + + ! propagate forward + CHAINP%POS = POS0 + DELT/6*(K1POS+2*K2POS+2*K3POS+K4POS) + IF (CHAINP%SHEARABLE) THEN + CHAINP%UVEC = UVEC0 + DELT/6*(K1UVEC+2*K2UVEC+2*K3UVEC+K4UVEC) + ! renormalize UVECs + DO B = 1,CHAINP%NPT + CALL NORMALIZE(CHAINP%UVEC(:,B)) + ENDDO + ENDIF + + ! calculate the stress tensor (XY component) on the beads + IF (PRESENT(STRESSXY)) THEN + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.TRUE.) + ELSE + CALL GETBEADRODFORCE(CHAINP,BROWNPOS,CRELAX,POSFORCE,ENERGY,.FALSE.,TENSBRFORCE) + ENDIF + COM(1) = SUM(CHAINP%POS(:,1))/CHAINP%NPT + COM(2) = SUM(CHAINP%POS(:,2))/CHAINP%NPT + COM(3) = SUM(CHAINP%POS(:,3))/CHAINP%NPT + CT = 0 + DO I = 1,3 + DO J = 1,3 + IF (I.EQ.J) CYCLE + CT = CT + 1 + IF (.NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*BROWNPOS(J,:) & + & + (chainp%pos(I,:)-COM(I))*(POSFORCE(J,:)-0.5*TENSBRFORCE(J,:))) + ! STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*BROWNPOS(J,:) & + ! & + (chainp%pos(I,:)-COM(I))*(POSFORCE(J,:)-TENSBRFORCE(J,:))) + !STRESSXY(CT) = STRESSXY(CT) - SUM(& + ! &(chainp%pos(I,:)-COM(I))*(posforce(j,:)+BROWNPOS(J,:))) + ! STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*(BROWNPOS(J,:)+TENSBRFORCE(J,:)) & + ! & + (chainp%pos(I,:)-COM(I))*(POSFORCE(J,:)-TENSBRFORCE(J,:))) + ELSE IF (.NOT.CHAINP%SHEARABLE) THEN + STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*BROWNPOS(J,:) & + & + (chainp%pos(I,:)-COM(I))*(POSFORCE(J,:)-UFORCE(J,:))) + ELSE + STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*BROWNPOS(J,:) & + & + (chainp%pos(I,:)-COM(I))*POSFORCE(J,:)) + ENDIF + ! STRESSXY(CT) = STRESSXY(CT) + SUM((chainp%pos(I,:))*(POSFORCE(J,:))) + ENDDO + ENDDO + + ! DO B = 1,CHAINP%NPT + ! !STRESSXY = STRESSXY - (POS0(1,B)-COM(1))*BROWNPOS(2,B) - (POS0(1,B)-COM(1))*POSFORCE(2,B) + ! !STRESSXY = STRESSXY - (0.5*(CHAINP%POS(1,B)-POS0(1,B))*BROWNPOS(2,B) + (chainp%POS(1,B)-COM(1))*POSFORCE(2,B)) + ! DO I = 1,3 + ! DO J = 1,3 + ! IF (I.EQ.J) CYCLE + ! STRESSXY = STRESSXY - (0.5*(CHAINP%POS(1,B)-POS0(1,B))*BROWNPOS(2,B) + (POS0(1,B)-COM(1))*POSFORCE(2,B))/6 + ! ENDDO + ! ENDDO + ! END DO + ENDIF + + END SUBROUTINE LANGEVINSTEPRK4 + + SUBROUTINE LANGEVINSTEP(CHAINP,DELT,KT,ENERGY,STRESSXY) + ! take a single step via overdamped Langevin dynamics + !!! ! use midpoint formula (eg: Grassia & Hinch, 1996) + ! based on Tao et al, 2005 + ! for orientation vectors, project all forces to perpendicular + ! and renormalize at each step + ! returns energy from the midpoint of the step (multiplied by kT) + USE KEYS, ONLY : FIXBEAD1,FIXBEADMID + USE MT19937, ONLY : RNORM, grnd + USE CHAINUTIL, ONLY : CHAIN, OBSTACLE + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + TYPE(OBSTACLE), POINTER :: OBP + DOUBLE PRECISION, INTENT(IN) :: KT,DELT + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: STRESSXY(6) + DOUBLE PRECISION :: POSFORCE(3,CHAINP%NPT), UFORCE(3,CHAINP%NPT) + DOUBLE PRECISION :: BROWNPOS(3,CHAINP%NPT), BROWNU(3,CHAINP%NPT) + INTEGER :: C,M, B, I ,J ,CT + DOUBLE PRECISION :: BROWNF, F, S2DTR(CHAINP%NPT), S2DTU(CHAINP%NPT), S2DTO, RHO, PHI,ST,CP,SP + DOUBLE PRECISION :: XVEC(3), YVEC(3), POS0(3,CHAINP%NPT),UVEC0(3,CHAINP%NPT) + DOUBLE PRECISION :: BROWNF1, BROWNF2, TORQUE(3), COM(3) + + PRINT*, 'LANGEVINSTEP SUBROUTINE HAS NOT BEEN TESTED IN A WHILE AND MAY NEED DEBUGGING' + stop 1 + + S2DTR = SQRT(2*KT/CHAINP%FRICTR(1:CHAINP%NPT)*DELT) + S2DTU = SQRT(2*KT/CHAINP%FRICTU(1:CHAINP%NPT)*DELT) + + !PRINT*, 'TESTX1:', S6DTR, S4DTU + + ! Get the deterministic forces + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.true.) + !CALL GETCHAINFORCEGAUSS(CHAINP,POSFORCE,ENERGY) + ENERGY = ENERGY*KT; POSFORCE = POSFORCE*KT; UFORCE = UFORCE*KT + + POS0 = CHAINP%POS; UVEC0 = CHAINP%UVEC + BROWNU = 0D0; BROWNPOS = 0D0 + IF (PRESENT(STRESSXY)) THEN + STRESSXY = 0D0 + ENDIF + + DO B = 1,CHAINP%NPT + ! translational brownian force + + BROWNPOS(1,B) = RNORM()*S2DTR(B) + BROWNPOS(2,B) = RNORM()*S2DTR(B) + BROWNPOS(3,B) = RNORM()*S2DTR(B) + + ! BROWNF = RNORM()*S6DTR ! magnitude + ! RHO = GRND()*2-1; ST = SQRT(1-RHO*RHO) + ! PHI = GRND()*2*PI + ! BROWNPOS(1,B) = BROWNF*ST*COS(PHI) + ! BROWNPOS(2,B) = BROWNF*ST*SIN(PHI) + ! BROWNPOS(3,B) = BROWNF*RHO + + IF (CHAINP%SHEARABLE) THEN + ! rotational brownian force + BROWNF1 = RNORM()*S2DTU(B) + BROWNF2 = RNORM()*S2DTU(B) + IF (CHAINP%UVEC(2,B).EQ.0D0.AND.CHAINP%UVEC(3,B).EQ.0D0) THEN + XVEC = (/0D0,1D0,0D0/) + YVEC = (/0D0,0D0,1D0/) + ELSE + CALL CROSS_PRODUCT(CHAINP%UVEC(:,B),(/1D0,0D0,0D0/),XVEC) + CALL CROSS_PRODUCT(CHAINP%UVEC(:,B),XVEC,YVEC) + ENDIF + !PHI = GRND()*2*PI; CP = COS(PHI); SP = SIN(PHI) + !BROWNU(:,B) = BROWNF*(CP*XVEC+SP*YVEC) + BROWNU(:,B) = BROWNF1*XVEC + BROWNF2*YVEC + + ! get just the perpendicular component of the U forces + UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + CALL CROSS_PRODUCT(UVEC0(:,B),UFORCE(:,B),TORQUE) + CALL CROSS_PRODUCT(TORQUE,UVEC0(:,B),UFORCE(:,B)) + ENDIF + + ! move to midpoint positions + !CHAINP%POS(:,B) = POS0(:,B) + BROWNPOS(:,B)/2 + DELT/2*POSFORCE(:,B)/CHAINP%FRICTR + !CHAINP%UVEC(:,B) = UVEC0(:,B) + BROWNU(:,B)/2 + DELT/2*UFORCE(:,B)/CHAINP%FRICTU + !IF (.not.B.EQ.1) THEN + ! IF (.not.B.EQ.(CHAINP%NPT+1)/2) THEN + IF (.NOT.((FIXBEAD1.AND.B.EQ.1).or.(FIXBEADMID.AND.B.EQ.(CHAINP%NPT+1)/2))) THEN + CHAINP%POS(:,B) = POS0(:,B) + BROWNPOS(:,B) + DELT*POSFORCE(:,B)/CHAINP%FRICTR(B) + ENDIF + IF (CHAINP%SHEARABLE.and.B.LT.CHAINP%NPT) THEN + CHAINP%UVEC(:,B) = UVEC0(:,B) + BROWNU(:,B) + DELT*UFORCE(:,B)/CHAINP%FRICTU(B) + ! renormalize orientation vector + CALL NORMALIZE(CHAINP%UVEC(:,B)) + ENDIF + + !SHEARXY = SHEARXY - 0.5*(CHAINP%POS(1,B)-POS0(1,B))*BROWNPOS(2,B) - CHAINP%POS0(1,B)*POSFORCE(2,B) + ! IF (PRESENT(STRESSXY)) THEN +! ! STRESSXY = STRESSXY - (POS0(1,B)-COM(1))*BROWNPOS(2,B) - (POS0(1,B)-COM(1))*POSFORCE(2,B) +! STRESSXY = STRESSXY - 0.5*(CHAINP%POS(1,B)-POS0(1,B))*BROWNPOS(2,B) - POS0(1,B)*POSFORCE(2,B) +! ENDIF + !STRESSCURV = STRESSCURV - POS0(1,B)*BENDFORCE(2,B) + END DO + + IF (PRESENT(STRESSXY)) THEN + CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY,.true.) + COM(1) = SUM(CHAINP%POS(:,1))/CHAINP%NPT + COM(2) = SUM(CHAINP%POS(:,2))/CHAINP%NPT + COM(3) = SUM(CHAINP%POS(:,3))/CHAINP%NPT + CT = 0 + DO I = 1,3 + DO J = 1,3 + IF (I.EQ.J) CYCLE + CT = CT + 1 + STRESSXY(CT) = STRESSXY(CT) - SUM(0.5*(CHAINP%POS(I,:)-POS0(I,:))*BROWNPOS(J,:)*CHAINP%FRICTR(:)/DELT & + & + (POS0(I,:)-COM(I))*POSFORCE(J,:)) + ! STRESSXY(CT) = STRESSXY(CT) - SUM((POS0(I,:)-COM(I))*(POSFORCE(J,:)+brownpos(j,:)*chainp%frictr/delt)) + ENDDO + ENDDO + ENDIF + ! Get the deterministic forces at the midpoint + !CALL GETCHAINFORCEGAUSS(CHAINP,POSFORCE,ENERGY) + ! print*, 'testx0' + ! CALL GETCHAINFORCEINT(CHAINP,POSFORCE,UFORCE,ENERGY) + ! ENERGY = ENERGY*KT; POSFORCE = POSFORCE*KT; UFORCE = UFORCE*KT + + ! DO B = 1,CHAINP%NPT + ! ! get just the perpendicular component of the U forces + ! UFORCE(:,B) = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),UVEC0(:,B))*UVEC0(:,B) + + ! ! move to final positions + ! CHAINP%POS(:,B) = POS0(:,B) + BROWNPOS(:,B) + DELT*POSFORCE(:,B)/CHAINP%FRICTR + ! CHAINP%UVEC(:,B) = UVEC0(:,B) + BROWNU(:,B) + DELT*UFORCE(:,B)/CHAINP%FRICTU + ! ! renormalize orientation vector + ! CALL NORMALIZE(CHAINP%UVEC(:,B)) + ! ENDDO + + END SUBROUTINE LANGEVINSTEP + + SUBROUTINE GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY,GETFORCE) + USE CHAINUTIL, ONLY : CHAIN + USE KEYS, ONLY : LOGRTERM, GAUSSIANCHAIN + ! get intrinsic force on each bead of the chain, as well as intrinsic energy + ! if GETFORCE=false only the energy is calculated + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: RFORCE(3,CHAINP%NPT),UFORCE(3,CHAINP%NPT) + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + LOGICAL, INTENT(IN) :: GETFORCE + INTEGER :: S,I,J + DOUBLE PRECISION :: EXTRAFORCE(3,CHAINP%NPT) + DOUBLE PRECISION :: POS1(3), POS2(3), UVEC1(3), UVEC2(3), DU(3), TMP + DOUBLE PRECISION :: DR(3), DRU, COEFF, NU + DOUBLE PRECISION :: DCRD(6), DRPERP(3,6), RPERP(3) + DOUBLE PRECISION :: EBEND, ESTRETCH, ESHEAR, ECOUPLE, ECONST + DOUBLE PRECISION :: LP,GAM,EPAR,EPERP,EC, NU1, NU2, CONSTMOD + DOUBLE PRECISION :: DVEC1(3), DVEC2(3), NDV1, NDV2, NDV12 + DOUBLE PRECISION :: LOGMAT(2),TMPMAT(2),BMINUS + DOUBLE PRECISION :: LOGMATFORCE(3,CHAINP%NPT,2), tmp2, DTMPNDV(3,3), LOGMATFORCEPREV(3,CHAINP%NPT,2) + + IF (GAUSSIANCHAIN) THEN + ! gaussian force components only + UFORCE = 0D0 + CALL GETCHAINFORCEGAUSS(CHAINP,RFORCE,ENERGY) + RETURN + ELSEIF (.NOT.CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + ! force for a bead-rod chain with inextensible segments, + ! including constraint tensions and the metric pseudopoential + PRINT*, 'CANNOT USE GETCHAINFORCEINT WITH BEAD-ROD MODEL' + STOP 1 + !UFORCE = 0D0 + !CALL GETBEADRODFORCE(CHAINP,RFORCE,ENERGY) + !RETURN + ENDIF + + EBEND = 0D0; ESTRETCH = 0D0; ESHEAR = 0D0; ECOUPLE = 0D0; ECONST = 0D0 + RFORCE = 0D0; UFORCE = 0D0; EXTRAFORCE = 0D0 + LOGMATFORCE = 0D0 + + CONSTMOD = CHAINP%CONSTMOD + LOGMAT = (/1D0,1D0/) + DO S = 1,CHAINP%NPT-1 ! Go through each segment + LP = CHAINP%LP(S) + EPAR = CHAINP%EPAR(S) + EPERP = CHAINP%EPERP(S) + EC = CHAINP%EC(S) + GAM = CHAINP%GAM(S) + + POS1 = CHAINP%POS(:,S) + POS2 = CHAINP%POS(:,S+1) + UVEC1 = CHAINP%UVEC(:,S) + UVEC2 = CHAINP%UVEC(:,S+1) + + ! ! stretch energy + COEFF = EPAR/(2*CHAINP%DELS(S)); + DR = POS2-POS1 + IF (CHAINP%SHEARABLE) THEN + DRU = DOT_PRODUCT(DR,UVEC1) + TMP = DRU - CHAINP%DELS(S)*GAM + IF (LOGRTERM) THEN + ESTRETCH = ESTRETCH + COEFF*TMP**2 - 2*LOG(DRu) + ELSE + ESTRETCH = ESTRETCH + COEFF*TMP**2 + ENDIF + + IF (GETFORCE) THEN + RFORCE(:,S+1) = RFORCE(:,S+1)+2*COEFF*TMP*UVEC1 + RFORCE(:,S) = RFORCE(:,S)-2*COEFF*TMP*UVEC1 + UFORCE(:,S) = UFORCE(:,S)+2*COEFF*TMP*DR + ENDIF + ELSE + DRU = SQRT(DOT_PRODUCT(DR,DR)) + TMP = DRU - CHAINP%DELS(S)*GAM + !print*, 'testx1:', epar/chainp%dels(s), chainp%dels(s)*gam + ! PRINT*, 'TESTX1:', DRU + IF (LOGRTERM) THEN + ESTRETCH = ESTRETCH + COEFF*TMP**2 + 2*LOG(DRU) + IF (VERBOSE) PRINT*, 'TESTX5:', DRU, LOG(DRU) + + ! update additional matrix term + TMP2 = EXP(-2*DRU*EPAR*GAM) + LOGMAT(2) = LOGMAT(2)*TMP2 + IF (GETFORCE) THEN + LOGMATFORCE(:,:,2) = LOGMATFORCE(:,:,2)*TMP2 + LOGMATFORCE(:,S+1,2) = LOGMATFORCE(:,S+1,2) - LOGMAT(2)*2*EPAR*GAM*DR/DRU + LOGMATFORCE(:,S,2) = LOGMATFORCE(:,S,2) + LOGMAT(2)*2*EPAR*GAM*DR/DRU + + !print*, 'testx1:', dot_product(dr,dr), 2*log(dru) + RFORCE(:,S+1) = RFORCE(:,S+1) + 2*COEFF*TMP/DRU*DR + 2/DRU**2*DR + RFORCE(:,S) = RFORCE(:,S) - 2*COEFF*TMP/DRU*DR - 2/DRU**2*DR + !EXTRAFORCE(:,S+1) = EXTRAFORCE(:,S+1) + 2/DRU**2*DR + !EXTRAFORCE(:,S) = EXTRAFORCE(:,S) - 2/DRU**2*DR + ENDIF + ELSE + ESTRETCH = ESTRETCH + COEFF*TMP**2 + IF (GETFORCE) THEN + RFORCE(:,S+1) = RFORCE(:,S+1) + 2*COEFF*TMP/DRU*DR + RFORCE(:,S) = RFORCE(:,S) - 2*COEFF*TMP/DRU*DR + ENDIF + ENDIF + + ENDIF + + ! bend energy + IF (S.LT.CHAINP%NPT) THEN + IF (CHAINP%SHEARABLE) THEN + DU = UVEC2-UVEC1 + ! !print*, 'testx1', s, du + ! COEFF = LP/(2*CHAINP%DELS(S)) + ! EBEND = EBEND + COEFF*DOT_PRODUCT(DU,DU) + + ! IF (GETFORCE) THEN + ! UFORCE(:,S+1) = UFORCE(:,S+1) +2*COEFF*DU + ! UFORCE(:,S) = UFORCE(:,S) - 2*COEFF*DU + ! ENDIF + !print*, 'testx2:', s, uforce(:,s) + EBEND = EBEND + LP/(CHAINP%DELS(S))*(1-DOT_PRODUCT(UVEC1,UVEC2)) + IF (GETFORCE) THEN + UFORCE(:,S+1) = UFORCE(:,S+1) -LP/(CHAINP%DELS(S))*UVEC1 + UFORCE(:,S) = UFORCE(:,S) - LP/(CHAINP%DELS(S)) *UVEC2 + ENDIF + ELSE + IF (S.EQ.CHAINP%NPT-1) CYCLE + DVEC1 = CHAINP%POS(:,S+1)-CHAINP%POS(:,S) + DVEC2 = CHAINP%POS(:,S+2)-CHAINP%POS(:,S+1) + NDV1 = SQRT(DOT_PRODUCT(DVEC1,DVEC1)) + NDV2 = SQRT(DOT_PRODUCT(DVEC2,DVEC2)) + NDV12 = NDV1*NDV2 + + COEFF = LP/CHAINP%DELS(S) + TMP = DOT_PRODUCT(DVEC1,DVEC2) + !print*, 'testx1:', coeff, tmp/ndv12, COEFF*(1-TMP/NDV12) + EBEND = EBEND + COEFF*(1-TMP/NDV12) + + IF (LOGRTERM) THEN + BMINUS = EXP(-2*COEFF*TMP/NDV12) + TMPMAT(1) = LOGMAT(1)+LOGMAT(2)*BMINUS + TMPMAT(2) = LOGMAT(1)*BMINUS + LOGMAT(2) + + IF (GETFORCE) THEN + ! derivatives of TMP/NDV12 wrt S+2,S,S+1 coords + DTMPNDV(:,3) = DVEC1/NDV12 - TMP*DVEC2/(NDV2**3*NDV1) + DTMPNDV(:,1) = - DVEC2/NDV12 + TMP*DVEC1/(NDV1**3*NDV2) + DTMPNDV(:,2) = - DVEC1/NDV12 + TMP*DVEC2/(NDV2**3*NDV1) & + & + DVEC2/NDV12 - TMP*DVEC1/(NDV1**3*NDV2) + + LOGMATFORCEPREV = LOGMATFORCE + LOGMATFORCE(:,:,1) = LOGMATFORCE(:,:,1) + LOGMATFORCEPREV(:,:,2)*BMINUS + LOGMATFORCE(:,:,2) = LOGMATFORCE(:,:,2) + LOGMATFORCEPREV(:,:,1)*BMINUS + DO I = 0,2 + LOGMATFORCE(:,S+I,1) = LOGMATFORCE(:,S+I,1) & + & - LOGMAT(2)*2*COEFF*BMINUS*DTMPNDV(:,I+1) + LOGMATFORCE(:,S+I,2) = LOGMATFORCE(:,S+I,2) & + & - LOGMAT(1)*2*COEFF*BMINUS*DTMPNDV(:,I+1) + ENDDO + ENDIF + LOGMAT = TMPMAT + ENDIF + IF (GETFORCE) THEN + RFORCE(:,S+2) = RFORCE(:,S+2) - COEFF*(DVEC1/NDV12 - TMP/NDV1/NDV2**3*DVEC2) + RFORCE(:,S+1) = RFORCE(:,S+1) - COEFF*(-DVEC1/NDV12 + TMP/NDV1/NDV2**3*DVEC2 + DVEC2/NDV12 - TMP/NDV2/NDV1**3*DVEC1) + RFORCE(:,S) = RFORCE(:,S) - COEFF*(-DVEC2/NDV12 + TMP/NDV2/NDV1**3*DVEC1) + ENDIF + ENDIF + ENDIF + + + IF (CHAINP%SHEARABLE) THEN + ! ! shear energy + COEFF = EPERP/(2*CHAINP%DELS(S)); + + RPERP = DR - DRU*UVEC1 + ESHEAR = ESHEAR + COEFF*DOT_PRODUCT(RPERP,RPERP) + + IF (GETFORCE) THEN + ! deriv of R_perp wrt coordinates dr, U + DRPERP = 0D0 + DO I = 1,3 + DRPERP(I,I) = 1D0 + DRPERP(I,I+3) = -DRU + DO J = 1,3 + DRPERP(I,J) = DRPERP(I,J) - UVEC1(I)*UVEC1(J) + DRPERP(I,J+3) = DRPERP(I,J+3) -DR(J)*UVEC1(I) + ENDDO + ENDDO + + DO J = 1,6 + DCRD(J) = DOT_PRODUCT(2*COEFF*RPERP,DRPERP(:,J)) + ENDDO + + RFORCE(:,S+1) = RFORCE(:,S+1)+ DCRD(1:3) + RFORCE(:,S) = RFORCE(:,S)-DCRD(1:3) + UFORCE(:,S) = UFORCE(:,S)+ DCRD(4:6) + ENDIF + + ! bend-shear coupling + IF (S.LT.CHAINP%NPT-1) THEN + COEFF = EC/CHAINP%DELS(S) + ECOUPLE = ECOUPLE + COEFF*DOT_PRODUCT(DU,RPERP) + + IF (GETFORCE) THEN + DO J = 1,6 + DCRD(J) = COEFF*DOT_PRODUCT(DU,DRPERP(:,J)) + ENDDO + + RFORCE(:,S+1) = RFORCE(:,S+1)+DCRD(1:3) + RFORCE(:,S) = RFORCE(:,S)-DCRD(1:3) + UFORCE(:,S)=UFORCE(:,S) + DCRD(4:6)-COEFF*RPERP + UFORCE(:,S+1) = UFORCE(:,S+1) +COEFF*RPERP + ENDIF + ENDIF + ENDIF + + END DO + + !ENERGY = ECONST; FORCE = FCONST; + + IF (CHAINP%SHEARABLE) THEN + ENERGY = EBEND + ESTRETCH+ESHEAR+ECOUPLE !+ECONST + ELSE + ENERGY = EBEND + ESTRETCH + IF (LOGRTERM) THEN + TMP = LOGMAT(1)+LOGMAT(2) + ENERGY = ENERGY - LOG(TMP) + IF (GETFORCE) THEN + !EXTRAFORCE = EXTRAFORCE - (LOGMATFORCE(:,:,1)+LOGMATFORCE(:,:,2))/TMP + RFORCE = RFORCE - (LOGMATFORCE(:,:,1)+LOGMATFORCE(:,:,2))/TMP + ENDIF + ENDIF + ! ENERGY = ESTRETCH + ENDIF + + IF (GETFORCE) THEN + RFORCE = - RFORCE; + IF (CHAINP%SHEARABLE) THEN + UFORCE = -UFORCE + ELSE + ! IF (LOGRTERM) THEN + ! UFORCE = -EXTRAFORCE + ! ELSE + UFORCE = 0D0 + !ENDIF + ENDIF + ENDIF + !ENERGY = LOGMAT(1)+LOGMAT(2) + !RFORCE = LOGMATFORCE(:,:,1)+LOGMATFORCE(:,:,2) + END SUBROUTINE GETCHAINFORCEINT + + SUBROUTINE GETCHAINFORCEGAUSS(CHAINP,RFORCE,ENERGY) + ! get chain energy and forces using just a gaussian model with EPAR as the moduluss + USE CHAINUTIL, ONLY : CHAIN + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: RFORCE(3,CHAINP%NPT) + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + INTEGER :: S,I,J + DOUBLE PRECISION :: POS1(3), POS2(3), UVEC1(3), UVEC2(3), DU(3), TMP + DOUBLE PRECISION :: DR(3), DRU, COEFF, NU + DOUBLE PRECISION :: DCRD(6), DRPERP(3,6), RPERP(3) + DOUBLE PRECISION :: EBEND, ESTRETCH, ESHEAR, ECOUPLE, ECONST + DOUBLE PRECISION :: LP,GAM,EPAR,EPERP,EC, NDR + + ENERGY = 0D0 + RFORCE = 0D0; + + DO S = 1,CHAINP%NPT-1 ! Go through each segment + EPAR = CHAINP%EPAR(S) + + POS1 = CHAINP%POS(:,S) + POS2 = CHAINP%POS(:,S+1) + + DR = POS2-POS1 + NDR = DR(1)*DR(1)+DR(2)*DR(2)+DR(3)*DR(3) + + ENERGY = ENERGY + EPAR/2/CHAINP%LS(1)*NDR + RFORCE(:,S+1) = RFORCE(:,S+1)+EPAR/CHAINP%LS(1)*DR + RFORCE(:,S) = RFORCE(:,S)-EPAR/CHAINP%LS(1)*DR + ENDDO + + RFORCE = -RFORCE + END SUBROUTINE GETCHAINFORCEGAUSS + + SUBROUTINE GETBEADRODFORCE(CHAINP,BROWNFORCE,CRELAX,RFORCE,ENERGY,PROJBROWN,TENSBRFORCE) + ! get chain energy and forces using a bead-rod model with constant + ! chain segment lengths (for now assumed the same throughout) + ! includes the constraint tensions and the metric pseudo-potential force + ! BROWNFORCE contains precalculated brownian forces for use in getting tension forces + ! CRELAX is the coefficient for the additional force to keep bond lengths numerically constrained + ! RFORCE, on exit, contains the potential, tension, and pseudo-potential forces + ! if PROJBROWN is true, alter BROWNFORCE so that on exit the components + ! that would alter the segment lengths are projected out + ! TENSBRFORCE is the component of the tension force that arises from the brownian force (after projection if projection is being done) + + USE CHAINUTIL, ONLY : CHAIN + USE KEYS, ONLY : USEPSEUDOFORCE + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(INout) :: BROWNFORCE(3,CHAINP%NPT) + DOUBLE PRECISION, INTENT(IN) :: CRELAX + LOGICAL, INTENT(IN) :: PROJBROWN + DOUBLE PRECISION, INTENT(OUT) :: RFORCE(3,CHAINP%NPT) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: TENSBRFORCE(3,CHAINP%NPT) + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + INTEGER :: S,I,J, NPT, NMAT, INFO + DOUBLE PRECISION :: TDET(0:CHAINP%NPT-1),BDET(CHAINP%NPT) + double precision, DIMENSION(CHAINP%NPT-1) :: DIAG, LOWDIAG, UPDIAG, UPDIAGSAVE, & + & GINVOFF,ndr!GINVDIAG + DOUBLE PRECISION :: DR(3,CHAINP%NPT-1), LAM(CHAINP%NPT-1),LAMBR(CHAINP%NPT-1) + DOUBLE PRECISION :: DETER, KAPPA, KEFF, DERVP(3), DERVM(3),DERVC(3),NDR2 + DOUBLE PRECISION :: TOTFORCE(3,CHAINP%NPT), L0, RFORCESAVE(3,CHAINP%NPT) + DOUBLE PRECISION :: DRTMP1(3), DRTMP2(3), NDRTMP1, NDRTMP2 + + ENERGY = 0D0; RFORCE = 0D0 + IF (PRESENT(TENSBRFORCE)) THEN + TENSBRFORCE = 0D0 + ENDIF + + ! set up the tridiagonal matrix for solving constraint forces + NPT= CHAINP%NPT + NMAT = NPT - 1 ! size of matrix = number of segmetns + DO I = 1,NMAT ! cycle through segments + ! segment vector + DR(:,I) = CHAINP%POS(:,I+1)-CHAINP%POS(:,I) + NDR2 = DOT_PRODUCT(DR(:,I),DR(:,I)) + NDR(I) = SQRT(NDR2) + !PRINT*, 'TESTX3:', I, NDR(I) + DIAG(I) = 2*NDR2 + !print*, 'testx3:', i, diag(i) + IF (I.GT.1) THEN + LOWDIAG(I) = -DOT_PRODUCT(DR(:,I-1),DR(:,I)) + !print*, 'testx4:', i, lowdiag(i) + ENDIF + ENDDO + UPDIAG(1:NMAT-1)=LOWDIAG(2:NMAT) + LOWDIAG(1) = 0D0; UPDIAG(CHAINP%NPT-1) = 0D0 + + IF (USEPSEUDOFORCE) THEN + ! calculate the pseudopotential forces; algorithm from Pasquali & Morse 2002 + ! first get, top and bottom matrix determinants + TDET(0) = 1 + TDET(1) = DIAG(1) + BDET(NPT) = 1 + BDET(NPT-1) = DIAG(NPT-1) + DO I = 1,NPT-2 + TDET(I+1) = DIAG(I+1)*TDET(I) - LOWDIAG(I+1)**2*TDET(I-1) + BDET(NPT-I-1) = DIAG(NPT-I-1)*BDET(NPT-I) - LOWDIAG(NPT-I)**2*BDET(NPT-I+1) + ENDDO + ! overall matrix determinant + DETER = TDET(NPT-1) + + !PRINT*, 'TESTX2:', dr(:,2) + !STOP 1 + ! get the diagonal and off-diagonal inverse G matrix elements + ! inv(G)_i-1,i + DO I = 1,NMAT + IF (I.GT.1) THEN + GINVOFF(I) = -LOWDIAG(I)*TDET(I-2)*BDET(I+1)/DETER + ENDIF + !GINVDIAG(I) = TDET(I-1)*BDET(I+1)/DETER + !print*, 'testx5:', i, ginv(i) + ENDDO + ENDIF + + ! and the bend potential and pseudopotential energy and forces + KAPPA = CHAINP%LP(1)/CHAINP%DELS(1) + + !ENERGY = 0.5*LOG(DETER) + !RFORCE(:,2) = RFORCE(:,2)-2*GINVDIAG(1)*DR(:,1) + !RFORCE(:,1) = RFORCE(:,1)+2*GINVDIAG(1)*DR(:,1) + DO I = 2,CHAINP%NPT-1 ! cycle over joints + ! potential and pseudopotential energies + ! DRTMP1 = CHAINP%POS(:,I)-CHAINP%POS(:,I-1); + ! DRTMP2 = CHAINP%POS(:,I+1)-CHAINP%POS(:,I); + ! NDRTMP1 = SQRT(SUM(DRTMP1**2)) + ! NDRTMP2 = SQRT(SUM(DRTMP2**2)) + ! !PRINT*, 'TESTX2RHO: ', I, SUM(DRTMP1*DRTMP2)/NDRTMP1/NDRTMP2 + ! ENERGY = ENERGY + KAPPA*(1-SUM(DRTMP1*DRTMP2)/NDRTMP1/NDRTMP2) + ENERGY = ENERGY + KAPPA*(1+LOWDIAG(I)/(NDR(I-1)*NDR(I))) + + ! upper bead derivatives + DERVP = DR(:,I-1)/NDR(I-1)/NDR(I) + LOWDIAG(I)/NDR(I-1)/NDR(I)**3*DR(:,I) + ! lower bead derivatives + DERVM = -DR(:,I)/NDR(I-1)/NDR(I) - LOWDIAG(I)/NDR(I)/NDR(I-1)**3*DR(:,I-1) + ! center bead derivatives + DERVC = -(DERVP+DERVM) + + + ! effective rigidity + IF (USEPSEUDOFORCE) THEN + RFORCE(:,I+1) = RFORCE(:,I+1) +KAPPA*DERVP + GINVOFF(I)*DR(:,I-1) + RFORCE(:,I) = RFORCE(:,I)+KAPPA*DERVC +GINVOFF(I)*(-DR(:,I-1)+DR(:,I)) + RFORCE(:,I-1) = RFORCE(:,I-1)+KAPPA*DERVM -GINVOFF(I)*DR(:,I) + ! if (present(tensbrforce)) then + ! tensbrFORCE(:,I+1) = tensbrFORCE(:,I+1) +KAPPA*DERVP + ! tensbrFORCE(:,I) = tensbrFORCE(:,I)+KAPPA*DERVC + ! tensbrFORCE(:,I-1) = tensbrFORCE(:,I-1)+KAPPA*DERVM + ! endif + ELSE + RFORCE(:,I+1) = RFORCE(:,I+1) +KAPPA*DERVP + RFORCE(:,I) = RFORCE(:,I)+KAPPA*DERVC + RFORCE(:,I-1) = RFORCE(:,I-1)+KAPPA*DERVM + ENDIF + + + !RFORCE(:,I+1) = RFORCE(:,I+1) + GINVOFF(I)*DR(:,I-1)!-2*GINVDIAG(I)*DR(:,I) + !RFORCE(:,I) = RFORCE(:,I)+GINVOFF(I)*(-DR(:,I-1)+DR(:,I))!+2*GINVDIAG(I)*DR(:,I) + !RFORCE(:,I-1) = RFORCE(:,I-1)-GINVOFF(I)*DR(:,I) + ENDDO + + RFORCESAVE = RFORCE + + ! IF (PRESENT(TENSBRFORCE)) THEN + ! TENSBRFORCE = RFORCE + ! ENDIF + + ! find the tension forces arising specifically from the brownian forces + IF (PRESENT(TENSBRFORCE).OR.PROJBROWN) THEN + DO I = 1,NMAT + ! keep track of the tensions arising from brownian forces separately + LAMBR(I) = DOT_PRODUCT(DR(:,I),brownFORCE(:,I+1)-brownFORCE(:,I)) + ENDDO + + ! PRINT*, 'TESTX0:' + ! DO I = 1,NPT-1 + ! PRINT*, LOWDIAG(I),DIAG(I),UPDIAG(I) + ! ENDDO + UPDIAGSAVE = UPDIAG + CALL DGTSL(NMAT,LOWDIAG,DIAG,UPDIAG,LAMBR,INFO) + UPDIAG = UPDIAGSAVE + IF (INFO.NE.0) THEN + PRINT*, 'ERROR IN SOLVING FOR BROWNIAN TENSION FORCES', info + STOP 1 + ENDIF + + IF (PROJBROWN) THEN + ! project out the tension parts of the brownian force + BROWNFORCE(:,1) = BROWNFORCE(:,1) + LAMBR(1)*DR(:,1) + DO I = 2,NPT-1 + BROWNFORCE(:,I) = BROWNFORCE(:,I) + LAMBR(I)*DR(:,I)-LAMBR(I-1)*DR(:,I-1) + ENDDO + BROWNFORCE(:,NPT) = BROWNFORCE(:,NPT) - LAMBR(NPT-1)*DR(:,NPT-1) + ENDIF + ENDIF + + ! find the overall tension forces + ! other forces include the bend, metric, brownian forces, and some + ! additional force to maintain bond lengths numerically + L0 = CHAINP%DELS(1)*CHAINP%GAM(1) + ! print*, 'TESTX1:', CRELAX, L0, ndr(1) + TOTFORCE = RFORCE + BROWNFORCE + DO I = 1,NMAT + LAM(I) = DOT_PRODUCT(DR(:,I),TOTFORCE(:,I+1)-TOTFORCE(:,I))+ CRELAX*(NDR(I)-L0) + ENDDO + + UPDIAGSAVE = UPDIAG + CALL DGTSL(NMAT,LOWDIAG,DIAG,UPDIAG,LAM,INFO) + UPDIAG = UPDIAGSAVE + IF (INFO.NE.0) THEN + PRINT*, 'ERROR IN SOLVING FOR TENSION FORCES' + STOP 1 + ENDIF + + RFORCE(:,1) = RFORCE(:,1) + LAM(1)*DR(:,1) + DO I = 2,NPT-1 + RFORCE(:,I) = RFORCE(:,I) + LAM(I)*DR(:,I)-LAM(I-1)*DR(:,I-1) + ENDDO + RFORCE(:,NPT) = RFORCE(:,NPT) - LAM(NPT-1)*DR(:,NPT-1) + + ! PRINT*, 'TESTX2:', DOT_PRODUCT(RFORCE(:,2)+BROWNFORCE(:,2)-RFORCE(:,1)-BROWNFORCE(:,1),& + ! & DR(:,1))/SQRT(SUM(DR(:,1)**2)) + + ! tension components from just the brownian forces + IF (PRESENT(TENSBRFORCE)) THEN + TENSBRFORCE = 0D0 + IF (.NOT.PROJBROWN) THEN + TENSBRFORCE(:,1) = TENSBRFORCE(:,1) + LAMBR(1)*DR(:,1) + DO I = 2,NPT-1 + TENSBRFORCE(:,I) = TENSBRFORCE(:,I) + LAMBR(I)*DR(:,I)-LAMBR(I-1)*DR(:,I-1) + ENDDO + TENSBRFORCE(:,NPT) = TENSBRFORCE(:,NPT) - LAMBR(NPT-1)*DR(:,NPT-1) + ENDIF + !PRINT*, 'TESTX3:', RFORCESAVE(2,1), RFORCE(2,1)-RFORCESAVE(2,1), BROWNFORCE(2,1), TENSBRFORCE(2,1) + + ! --------- all the tension forces --------- + ! TENSBRFORCE = RFORCE-RFORCESAVE + ENDIF + + + END SUBROUTINE GETBEADRODFORCE + +END MODULE BROWNDYN diff --git a/BasicWLC/dssWLC/source/chainutil.f90 b/BasicWLC/dssWLC/source/chainutil.f90 new file mode 100644 index 00000000..7f229028 --- /dev/null +++ b/BasicWLC/dssWLC/source/chainutil.f90 @@ -0,0 +1,969 @@ +MODULE CHAINUTIL + USE KEYS, ONLY : VERBOSE + IMPLICIT NONE + + ! utilities for defining and dealing with chain object + + TYPE CHAIN + INTEGER :: NPT ! current number of beads + INTEGER :: MAXNPT ! maximal possible number of beads + + ! positions and quaternion orientations for each bead + ! 1st index is coordinate, 2nd index is bead number + DOUBLE PRECISION, POINTER :: POS(:,:) + DOUBLE PRECISION, POINTER :: UVEC(:,:) + ! SHEARABLE, STRETCHABLE: can the chain stretch and shear? + ! COUPLED: is there bend-shear coupling? + ! FINITEXT: prevent segments from stretching beyond contour length + LOGICAL :: SHEARABLE, STRETCHABLE, COUPLED, FINITEXT + DOUBLE PRECISION,POINTER :: LS(:) ! segment length + ! -------- used for brownian dynamics only + ! DELS is not currently used???? + DOUBLE PRECISION, POINTER :: DELS(:) !different lengths for each segment + ! single vector of coordinates for the chain + ! for each bead, lists 3 coords for position and 3 for the U vector +! DOUBLE PRECISION, POINTER :: COORDS(:) +! INTEGER :: NCRD + ! --------- + + ! energy parameters (FOR EACH SEGMENT) + ! LP = persistence length + ! GAM = natural speed + ! EPERP,EPAR = shear and stretch moduli + ! EC = bend-shear coupling + DOUBLE PRECISION, POINTER :: LP(:),GAM(:),EPERP(:),EPAR(:),EC(:) + + ! FORCE = external force in kT/nm + ! FINITSHEAR = how much of shear energy component is corrected for finite extension + ! anything greater than 0 will limit overall segment extension + DOUBLE PRECISION :: FINITSHEAR, FORCE + ! spring modulus for U vector normalization constraint + DOUBLE PRECISION :: CONSTMOD + DOUBLE PRECISION :: MU + ! does the chain object have a force associated with it? + LOGICAL :: HASFORCE + + ! sterics + LOGICAL :: STERICS ! use sterics? + DOUBLE PRECISION :: STERRAD,STERRAD2 ! steric radius squared + DOUBLE PRECISION :: STERMOD, STERICENERGY + ! when calculating sterics skip this many atoms on either side + INTEGER :: STERSKIP + DOUBLE PRECISION :: MINSEGLEN, MAXSEGLEN + + ! store the junction energy associated with each bead + DOUBLE PRECISION, POINTER :: BEADENERGY(:) + ! and the energy associated with the external force + DOUBLE PRECISION :: FORCEENERGY + + ! friction coefficients for bead position and orientation vector + DOUBLE PRECISION, POINTER :: FRICTR(:), FRICTU(:) + + ! fixed beads (both positions and orientations fixed for now) + INTEGER :: NFIXBEAD + INTEGER, POINTER :: FIXBEAD(:) + LOGICAL, POINTER :: ISFIXED(:) + + ! have arrays been allocated yet? + LOGICAL :: ARRAYSET = .FALSE. + END type CHAIN + + TYPE OBSTACLE + ! object corresponding to a spherical obstacle to the chain + ! potential is quadratic within a cutoff radius + DOUBLE PRECISION :: COORDS(3) + + ! cutoff radius and modulus for the potential + DOUBLE PRECISION :: RAD, MOD + ! friction coefficient for the obstacle + DOUBLE PRECISION :: FRICT + + END type OBSTACLE + +CONTAINS + SUBROUTINE RESETLINKERS(CHAINP,CUTOFF,RESET) + ! reset all linker lengths in the chain to the ground state value + ! while keeping relative linker orientations unchanged + ! only reset if any linker length is off by more than CUTOFF Fraction + USE GENUTIL, ONLY : NORM + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN) :: CUTOFF + LOGICAL, INTENT(OUT) :: RESET + INTEGER :: B + DOUBLE PRECISION :: TANV(3,CHAINP%NPT-1), ntv, COM(3), NEWCOM(3) + + RESET = .FALSE. + ! get normalized linker vectors + DO B = 1,CHAINP%NPT-1 + TANV(:,B) = CHAINP%POS(:,B+1)-CHAINP%POS(:,B) + NTV = NORM(TANV(:,B)); + IF ((NTV-CHAINP%LS(B))/CHAINP%LS(B).GT.CUTOFF) THEN + RESET = .TRUE. + ENDIF + TANV(:,B) = TANV(:,B)/NTV + END DO + + ! reset all beads; keep center of mass constant + IF (RESET) THEN + COM = SUM(CHAINP%POS,2)/CHAINP%NPT + DO B = 2,CHAINP%NPT + CHAINP%POS(:,B) = CHAINP%POS(:,B-1)+TANV(:,B-1)*CHAINP%LS(B-1)*CHAINP%GAM(B-1) + ENDDO + NEWCOM = SUM(CHAINP%POS,2)/CHAINP%NPT + + DO B = 1,CHAINP%NPT + CHAINP%POS(:,B) = CHAINP%POS(:,B) + COM-NEWCOM + ENDDO + ENDIF + + END SUBROUTINE RESETLINKERS + + ! -------------- statistics functions ------------ + SUBROUTINE GETCHAINRG(CHAINP,RG) + ! get radius of gyration of the chain, using the POS coordinates + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: RG + DOUBLE PRECISION :: RC(3),DIFF(3) + INTEGER :: B,I + + DO I = 1,3 + RC(I) = SUM(CHAINP%POS(I,1:CHAINP%NPT))/CHAINP%NPT + ENDDO + + RG = 0D0 + DO B = 1,CHAINP%NPT + DIFF = CHAINP%POS(:,B)-RC + RG = RG + DOT_PRODUCT(DIFF,DIFF) + ENDDO + RG = SQRT(RG/CHAINP%NPT) + + END SUBROUTINE GETCHAINRG + + +! --------- INPUT/OUTPUT + SUBROUTINE INPUTSNAPSHOT(CHAINLIST,NCHAIN,FILENAME,NSKIP,NREAD) + ! read in NCHAIN snapshots from a file + ! and put coordinates into a list of chains + ! NREAD returns the number of chains successfully read + !(in case there are less than NCHAIN chains specified in the input file) + ! NSKIP: skip the first few configurations + IMPLICIT NONE + INTEGER, INTENT(IN) :: NCHAIN,NSKIP + TYPE(CHAIN), TARGET :: CHAINLIST(NCHAIN) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(OUT) :: NREAD + + CHARACTER(LEN=*) :: FILENAME + INTEGER :: TMPI1, TMPI2, NPTREAD, C, B, CHECK + CHARACTER :: TMPC + DOUBLE PRECISION :: LSREAD, LPREAD, GAMREAD, EPARREAD, EPERPREAD, ECREAD + DOUBLE PRECISION :: POSREAD(3), UVECREAD(3), CHECKPARAMS + + NREAD = 0 + OPEN(UNIT=55,FILE=FILENAME,STATUS='OLD') + DO C = 1,NSKIP + READ(UNIT=55,FMT='(A,1X,2I12)',IOSTAT=CHECK) TMPC,TMPI1,TMPI2 + IF (CHECK.LT.0) THEN + EXIT + ELSEIF (CHECK.GT.0) THEN + PRINT*, 'ERROR in reading in snapshot data. I line', C, TMPC, TMPI1, TMPI2 + print*, CHECK + STOP 1 + ENDIF + + READ(55,'(A,1X,I12)',IOSTAT=CHECK) TMPC,NPTREAD + !print*, 'testx3:', c, nptread + IF (CHECK.LT.0) THEN + EXIT + ELSEIF (CHECK.GT.0) THEN + PRINT*, 'ERROR in reading in snapshot data. C line', C, TMPC, NPTREAD + STOP 1 + ENDIF + + DO B = 1,NPTREAD + READ(55,'(A,1X,12G20.10)') TMPC, POSREAD,UVECREAD,& + & LSREAD, LPREAD, GAMREAD, EPARREAD, & + & EPERPREAD, ECREAD + ENDDO + PRINT*, 'SKIPPING CONFIG:', C + ENDDO + + DO C = 1,NCHAIN + CHAINP=>CHAINLIST(C) + READ(UNIT=55,FMT='(A,1X,2I12)',IOSTAT=CHECK) TMPC,TMPI1,TMPI2 + IF (CHECK.LT.0) THEN + EXIT + ELSEIF (CHECK.GT.0) THEN + PRINT*, 'ERROR in reading in snapshot data. I line', C, TMPC, TMPI1, TMPI2 + STOP 1 + ENDIF + + READ(55,'(A,1X,I12)',IOSTAT=CHECK) TMPC,NPTREAD + IF (CHECK.LT.0) THEN + EXIT + ELSEIF (CHECK.GT.0) THEN + PRINT*, 'ERROR in reading in snapshot data. C line', C, TMPC, NPTREAD + STOP 1 + ENDIF + IF (NPTREAD.NE.CHAINP%NPT) THEN + PRINT*, 'ERROR in reading snapshot data. Wrong number of beads expected.', C, NPTREAD, CHAINP%NPT + STOP 1 + ENDIF + + DO B = 1,CHAINP%NPT + READ(55,'(A,1X,12G20.10)') TMPC, CHAINP%POS(:,B),CHAINP%UVEC(:,B),& + & LSREAD, LPREAD, GAMREAD, EPARREAD, & + & EPERPREAD, ECREAD + if (B.LT.CHAINP%NPT) THEN + ! print*, 'testx1:', LSREAD,chainp%ls(b) + CHECKPARAMS = MaxVAL([ABS(LSREAD-CHAINP%LS(B)),ABS(LPREAD-CHAINP%LP(B)),& + & ABS(GAMREAD-CHAINP%GAM(B)),ABS(EPARREAD-CHAINP%EPAR(B)),& + & ABS(EPERPREAD-CHAINP%EPERP(B)),ABS(ECREAD-CHAINP%EC(B))]) + IF (CHECKPARAMS.GT.1D-9) THEN + PRINT*, 'ERROR in reading snapshot. Wrong segment parameters', B + print*, LSREAD, LPREAD, GAMREAD, EPARREAD, EPERPREAD, ECREAD + PRINT*, CHAINP%LS(B), CHAINP%LP(B), CHAINP%EPAR(B), CHAINP%EPERP(B), CHAINP%EC(B) + STOP 1 + ENDIF + ENDIF + + ENDDO + + NREAD = NREAD + 1 + !print*, 'SUCCESSFULLY READ CONFIG:', C + ENDDO + CLOSE(55) + END SUBROUTINE INPUTSNAPSHOT + + SUBROUTINE OUTPUTSNAPSHOT(CHAINP,FILENAME,NUM,APPEND,NEXTRA,EXTRADATA) + ! output a snapshot to file, appending if file already exists + ! NUM is an extra number to add to the info line + ! optionally, attach an extra array of data to each bead + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + CHARACTER(LEN=*) :: FILENAME + INTEGER, INTENT(IN) :: NUM + LOGICAL, INTENT(IN) :: APPEND + INTEGER, INTENT(IN), OPTIONAL :: NEXTRA + DOUBLE PRECISION, POINTER, OPTIONAL :: EXTRADATA(:,:) + INTEGER :: B + CHARACTER*10 :: INTSTR + CHARACTER*50 :: FMT + LOGICAL :: WRITEEXTRA + + WRITEEXTRA = PRESENT(NEXTRA).AND.PRESENT(EXTRADATA) + + IF (APPEND) THEN + OPEN(UNIT=99,FILE=FILENAME,POSITION='APPEND') + ELSE + OPEN(UNIT=99,FILE=FILENAME,POSITION='REWIND') + ENDIF + + ! write information line + WRITE(99,'(A,1X,2I12)') 'I',1,NUM + WRITE(99,'(A,1X,I12)') 'C',CHAINP%NPT + + ! write bead lines + IF (WRITEEXTRA) THEN + WRITE(INTSTR,'(I10)') NEXTRA+12 + FMT = '(A,1X,' // TRIM(ADJUSTL(INTSTR)) // 'G20.10)' + ELSE + FMT = '(A,1X,12G20.10)' + ENDIF + + ! PRINT*, 'TESTX1:', FMT + + DO B = 1,CHAINP%NPT-1 + IF (WRITEEXTRA) THEN + WRITE(99,FMT) 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B),& + & CHAINP%LS(B), CHAINP%LP(B), CHAINP%GAM(B), CHAINP%EPAR(B), & + & CHAINP%EPERP(B), CHAINP%EC(B),EXTRADATA(1:NEXTRA,B) + ELSE + WRITE(99,FMT) 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B),& + & CHAINP%LS(B), CHAINP%LP(B), CHAINP%GAM(B), CHAINP%EPAR(B), & + & CHAINP%EPERP(B), CHAINP%EC(B) + ENDIF + ENDDO + B = CHAINP%NPT + IF (WRITEEXTRA) THEN + WRITE(99,FMT) 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B), 0,0,0,0,0,0, EXTRADATA(1:NEXTRA,B) + ELSE + WRITE(99,'(A,1X,12G20.10)') 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B), 0,0,0,0,0,0 + ENDIF + + CLOSE(99) + + END SUBROUTINE OUTPUTSNAPSHOT + + SUBROUTINE OUTPUTCHAINOBST(CHAINP,OBP,FILENAMe) + ! output chain and obstacle coords into a file named FILENAME + ! based on COORDS array of chain (as used in BD sims) + + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP + TYPE(OBSTACLE), POINTER :: OBP + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + INTEGER :: B + + OPEN(UNIT=99,FILE=FILENAME,STATUS='UNKNOWN') + + ! for each bead dump position coords followed by orientation coords + + DO B = 1,CHAINP%NPT + WRITE(99,'(A1,1x,6G20.10)') 'B',CHAINP%POS(:,B),CHAINP%UVEC(:,B) + ENDDO + + + ! then dump obstacle coords + WRITE(99,'(A1,1X,3G20.10)') 'O',OBP%COORDS + + CLOSE(99) + END SUBROUTINE OUTPUTCHAINOBST + + + ! ---------- energy functions for MC ----------- + SUBROUTINE GETENERGY(CHAINP,ENERGY) + ! get the overall energy associated with the current chain configuration + ! fill in the full chainp%beadenergy array with bead-specific energies + ! also include the energy due to external force + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + INTEGER :: B + + ENERGY = 0D0 + + ! get bead-specific energies + DO B = 2,CHAINP%NPT + CALL GETBEADENERGY(CHAINP,B,CHAINP%BEADENERGY(B)) + !IF (VERBOSE) PRINT*, 'TESTX3:', B, CHAINP%BEADENERGY(B), & + ! & sqrt(dot_product(chainp%pos(:,b)-chainp%pos(:,b-1),chainp%pos(:,b)-chainp%pos(:,b-1))) + ENDDO + + ! get energy from external force + IF (CHAINP%HASFORCE) THEN + CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY ) + ELSE + CHAINP%FORCEENERGY = 0D0 + END IF + IF (CHAINP%STERICS) CALL GETSTERICENERGY(CHAINP,CHAINP%STERICENERGY) + + ! total energy + ENERGY = CHAINP%STERICENERGY + SUM(CHAINP%BEADENERGY(1:CHAINP%NPT)) -CHAINP%NPT*CHAINP%MU +CHAINP%FORCEENERGY + + END SUBROUTINE GETENERGY + + SUBROUTINE GETSTERICENERGY(CHAINP,ENERGY) + ! get steric energy from all pairs of beads + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + INTEGER :: B1, B2 + DOUBLE PRECISION :: DIFF(3), ND2 + + ENERGY = 0D0 + DO B1 = 1,CHAINP%NPT + DO B2 = 1,CHAINP%NPT + IF (ABS(B1-B2).LE.CHAINP%STERSKIP) CYCLE + DIFF = CHAINP%POS(:,B2)-CHAINP%POS(:,B1) + ND2 = DOT_PRODUCT(DIFF,DIFF) + IF (ND2.LT.CHAINP%STERRAD2) THEN + ENERGY = ENERGY + CHAINP%STERMOD*(CHAINP%STERRAD2-ND2)**2 + ENDIF + ENDDO + ENDDO + + END SUBROUTINE GETSTERICENERGY + + SUBROUTINE CHECKSTERICCLASH(CHAINP,NB1,SET1,NB2,SET2, CLASH) + ! check for steric clashes between any bead in set1 and any bead in set2 + ! ignore pairs of identical beads + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: NB1, NB2, SET1(NB1), SET2(NB2) + LOGICAL, INTENT(OUT) :: CLASH + INTEGER :: C1, C2, B1, B2 + DOUBLE PRECISION :: DIFF(3), D2 + + CLASH = .FALSE. + + DO C1 = 1,NB1 + B1 = SET1(C1) + DO C2 = 1,NB2 + B2 = SET2(C2) + IF (ABS(B1-B2).LE.CHAINP%STERSKIP) CYCLE + + DIFF = CHAINP%POS(:,B1)-CHAINP%POS(:,B2) + D2 = DOT_PRODUCT(DIFF,DIFF) + + IF (D2.LT.CHAINP%STERRAD2) THEN + CLASH = .TRUE. + RETURN + ENDIF + ENDDO + ENDDO + END SUBROUTINE CHECKSTERICCLASH + + SUBROUTINE GETFORCEENERGY(CHAINP,ENERGY) + ! THIS IS OUT OF DATE AND INCOMPATIBLE WITH MANYCHAIN SETUP + ! get the energy associated with external force + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + + ENERGY = 0D0 + IF (CHAINP%HASFORCE) THEN + ENERGY = -(CHAINP%POS(3,CHAINP%NPT)-CHAINP%POS(3,1)-SUM(CHAINP%LS(1:CHAINP%NPT-1)))*CHAINP%FORCE + ENDIF + !PRINT*, 'TESTX1:', CHAINP%FORCE, ENERGY + END SUBROUTINE GETFORCEENERGY + + SUBROUTINE GETBEADQUINT(CHAINP,B,NRHO,NPHI,QINT) + ! get the partition function for a particular bead, integrated over U vector + ! assuming the bead is located between two beads with fixed R and U + USE GENUTIL, ONLY : NORM, PI, CROSS_PRODUCT + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B, NRHO, NPHI + DOUBLE PRECISION, INTENT(OUT) :: QINT + DOUBLE PRECISION :: UVECSAVE(3), BEADESAVE + DOUBLE PRECISION :: XAX(3), YAX(3), ZAX(3), DELRHO, DELPHI, ADD, SR + DOUBLE PRECISION :: RHO, PHI, ENERGY1, ENERGY2, ENERGY0 + INTEGER :: RC, PC + + IF (B.LE.1.OR.B.GE.CHAINP%NPT) THEN + PRINT*, 'ERROR IN GETBEADQUINT: bad bead', B + stop 1 + ENDIF + IF (.NOT.(CHAINP%SHEARABLE.AND.CHAINP%STRETCHABLE)) THEN + PRINT*, 'ERROR IN GETBEADQUINT: chain must be stretchable and shearable' + STOP 1 + ENDIF + + ! save current uvector value + UVECSAVE = CHAINP%UVEC(:,B) + BEADESAVE = CHAINP%BEADENERGY(B) + + ! set up previous bead coordinate system + ZAX = CHAINP%UVEC(:,B-1) + IF (ZAX(2)*ZAX(2)+ZAX(3)*ZAX(3).EQ.0) THEN + XAX = (/0D0,0D0,1D0/) + YAX = (/0D0,-1D0,0D0/) + ELSE + CALL CROSS_PRODUCT(ZAX,(/1D0,0D0,0D0/),XAX) + XAX = XAX/NORM(XAX) + CALL CROSS_PRODUCT(ZAX,XAX,YAX) + ENDIF + + ! get current energy to rescale everything by that + CALL GETBEADENERGY(CHAINP,B,ENERGY1) + CALL GETBEADENERGY(CHAINP,B+1,ENERGY2) + ENERGY0 = ENERGY1+ENERGY2 + !print*, 'testx1:', energy0 + + !UVEC2 = CHAINP%UVEC(:,B+1) + !RHO12 = DOT_PRODUCT(UVEC1,UVEC2) + + DELRHO = 2d0/(NRHO-1); + DELPHI = 2*PI/(NPHI-1); + + QINT = 0D0 + OPEN(UNIT=44,FILE='qintmat.out') + DO RC = 1,NRHO + RHO = 1-2*DBLE(RC-1)/(NRHO-1) + SR = SQRT(1-RHO*RHO) + DO PC = 1,NPHI + PHI = 2*PI*DBLE(PC-1)/(NPHI-1) + + CHAINP%UVEC(:,B) = SR*COS(PHI)*XAX + SR*SIN(PHI)*YAX + RHO*ZAX + CALL GETBEADENERGY(CHAINP,B,ENERGY1) + CALL GETBEADENERGY(CHAINP,B+1,ENERGY2) + + ADD = EXP(-(ENERGY1+ENERGY2-ENERGY0)) + ! IF (B.EQ.8) THEN + ! ! print*, 'testx1:', rc, pc, energy1+energy2-energy0, add*delrho*delphi, qint*delrho*delphi + ! WRITE(44,*) RHO, PHI, energy1+energy2-energy0, add*delrho*delphi, qint*delrho*delphi + ! ENDIF + IF (RC.EQ.1.OR.RC.EQ.NRHO) THEN + ADD = ADD*0.5 + ENDIF + IF (PC.EQ.1.OR.PC.EQ.NRHO) THEN + ADD = ADD*0.5 + ENDIF + QINT = QINT + ADD + ENDDO + ENDDO + CLOSE(44) + + ! print*, 'testxb:', energy0, delrho, delphi + ! print*, 'testx2:', qint*delrho*delphi + QINT = QINT*DELRHO*DELPHI*EXP(-ENERGY0) + + ! restore to original values + CHAINP%UVEC(:,B) = UVECSAVE + CHAINP%BEADENERGY(B) = BEADESAVE + END SUBROUTINE GETBEADQUINT + + SUBROUTINE GETBEADQRINT(CHAINP,B,Npt,QINT) + ! get the partition function for a particular bead, integrated over R position + ! assuming the bead is located between two beads with fixed R and U + USE GENUTIL, ONLY : NORM, PI, CROSS_PRODUCT + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B, NPT + DOUBLE PRECISION, INTENT(OUT) :: QINT + DOUBLE PRECISION :: POSSAVE(3), BEADESAVE + DOUBLE PRECISION :: XAX(3), YAX(3), ZAX(3), ADD, ZRANGE,XYRANGE,DELZ,DELXY + DOUBLE PRECISION :: X,Y,Z, ENERGY1, ENERGY2, ENERGY0, X0, Y0, Z0 + INTEGER :: XC,ZC,YC + + IF (B.LE.1.OR.B.GE.CHAINP%NPT) THEN + PRINT*, 'ERROR IN GETBEADQUINT: bad bead', B + stop 1 + ENDIF + IF (.NOT.(CHAINP%SHEARABLE.AND.CHAINP%STRETCHABLE)) THEN + PRINT*, 'ERROR IN GETBEADQUINT: chain must be stretchable and shearable' + STOP 1 + ENDIF + + ! save current position value + POSSAVE = CHAINP%POS(:,B) + BEADESAVE = CHAINP%BEADENERGY(B) + + ! set up previous bead coordinate system + ZAX = CHAINP%UVEC(:,B-1) + IF (ZAX(2)*ZAX(2)+ZAX(3)*ZAX(3).EQ.0) THEN + XAX = (/0D0,0D0,1D0/) + YAX = (/0D0,-1D0,0D0/) + ELSE + CALL CROSS_PRODUCT(ZAX,(/1D0,0D0,0D0/),XAX) + XAX = XAX/NORM(XAX) + CALL CROSS_PRODUCT(ZAX,XAX,YAX) + ENDIF + + ! get current energy to rescale everything by that + CALL GETBEADENERGY(CHAINP,B,ENERGY1) + CALL GETBEADENERGY(CHAINP,B+1,ENERGY2) + ENERGY0 = ENERGY1+ENERGY2 + !print*, 'testx1:', b, energy0 + + X0 = DOT_PRODUCT(CHAINP%POS(:,B)-CHAINP%POS(:,B-1),XAX) + Y0 = DOT_PRODUCT(CHAINP%POS(:,B)-CHAINP%POS(:,B-1),YAX) + Z0 = DOT_PRODUCT(CHAINP%POS(:,B)-CHAINP%POS(:,B-1),ZAX) + + !how far out to integrate + ZRANGE = 3/SQRT(CHAINP%EPAR(B)) + XYRANGE = 3/SQRT(CHAINP%EPERP(B)) + + DELZ = 2*ZRANGE/(NPT-1); + DELXY = 2*XYRANGE/(NPT-1); + + QINT = 0D0 + !OPEN(UNIT=44,FILE='qintRmat.out') + DO XC = 1,NPT +! X = (-1+2*DBLE(XC-1)/(NPT-1))*XYRANGE + X = (-1+2*DBLE(XC-1)/(NPT-1))*XYRANGE + Y0 + DO YC = 1,NPT + !Y = (-1+2*DBLE(YC-1)/(NPT-1))*XYRANGE + Y = (-1+2*DBLE(YC-1)/(NPT-1))*XYRANGE + Y0 + DO ZC= 1,NPT + !Z = (-1+2*DBLE(ZC-1)/(NPT-1))*ZRANGE + CHAINP%GAM(B)*CHAINP%LS(B) + Z = (-1+2*DBLE(ZC-1)/(NPT-1))*ZRANGE + Z0 + + CHAINP%POS(:,B) = CHAINP%POS(:,B-1) + X*XAX + Y*YAX+Z*ZAX + CALL GETBEADENERGY(CHAINP,B,ENERGY1) + CALL GETBEADENERGY(CHAINP,B+1,ENERGY2) + + ADD = EXP(-(ENERGY1+ENERGY2-ENERGY0)) + !IF (B.EQ.8) THEN + !print*, 'testx1:', rc, pc, energy1+energy2-energy0, add*delrho*delphi, qint*delrho*delphi + ! WRITE(44,*) X,Y,Z, energy1+energy2-energy0, add*delXY*DELXY*DELZ, qint*delXY*DELXY*DELZ + !ENDIF + IF (ZC.EQ.1.OR.ZC.EQ.NPT) THEN + ADD = ADD*0.5 + ENDIF + IF (XC.EQ.1.OR.XC.EQ.NPT) THEN + ADD = ADD*0.5 + ENDIF + IF (YC.EQ.1.OR.YC.EQ.NPT) THEN + ADD = ADD*0.5 + ENDIF + QINT = QINT + ADD + ENDDO + ENDDO + ENDDO + !CLOSE(44) + + ! print*, 'testxb:', energy0, delrho, delphi + QINT = QINT*DELZ*DELXY*DELXY*EXP(-ENERGY0) + + ! restore to original values + CHAINP%POS(:,B) = POSSAVE + CHAINP%BEADENERGY(B) = BEADESAVE + END SUBROUTINE GETBEADQRINT + + SUBROUTINE GETBEADENERGY(CHAINP,B,ENERGY) + ! get the energy associated with a particular bead + ! (for the segment preceeding the bead) + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + DOUBLE PRECISION :: DPOS(3),DU(3),UU,RPAR,RPERP(3),RPERP2 + DOUBLE PRECISION :: ROTMAT(3,3), NDR,NDRSHIFT,RMAX,RMAX2 + DOUBLE PRECISION :: DEL, GAM, LP,EPAR,EPERP,EC + DOUBLE PRECISION :: D1D2,ND1,ND2,DPOS2(3) + ! DOUBLE PRECISION :: FINSHIFT + !FINSHIFT = 1D-3 + + IF(B.EQ.1) THEN + ENERGY=0D0 + RETURN + END IF + + DEL = CHAINP%LS(B-1); LP = CHAINP%LP(B-1); EPAR = CHAINP%EPAR(B-1) + EPERP = CHAINP%EPERP(B-1); GAM = CHAINP%GAM(B-1); EC = CHAINP%EC(B-1) + + ! bend angle + DU = CHAINP%UVEC(:,B)-CHAINP%UVEC(:,B-1) + UU = DOT_PRODUCT(CHAINP%UVEC(:,B),CHAINP%UVEC(:,B-1)) + + ! displacement relative to previous coord system + + DPOS = CHAINP%POS(:,B)-CHAINP%POS(:,B-1) + + IF (CHAINP%SHEARABLE) THEN + RPAR = DOT_PRODUCT(DPOS,CHAINP%UVEC(:,B-1)) + RPERP = DPOS - RPAR*CHAINP%UVEC(:,B-1) + RPERP2 = DOT_PRODUCT(RPERP,RPERP) + ENERGY = LP/DEL*(1-UU) + ELSEIF (CHAINP%STRETCHABLE) THEN + IF (B.LT.CHAINP%NPT) THEN + DPOS2 = CHAINP%POS(:,B+1)-CHAINP%POS(:,B) + ND1 = SQRT(DOT_PRODUCT(DPOS,DPOS)) + ND2 = SQRT(DOT_PRODUCT(DPOS2,DPOS2)) + D1D2 = DOT_PRODUCT(DPOS,DPOS2) + ENERGY = LP/DEL*(1-D1D2/ND1/ND2) + ENDIF + RPAR = ND1 + ELSE + IF (B.LT.CHAINP%NPT) THEN + DPOS2 = CHAINP%POS(:,B+1)-CHAINP%POS(:,B) + D1D2 = DOT_PRODUCT(DPOS,DPOS2) + ENERGY = LP/DEL*(1-D1D2/(DEL*GAM)**2) + ELSE + ENERGY = 0D0 + ENDIF + ENDIF + + + IF (CHAINP%STRETCHABLE) THEN + IF (CHAINP%FINITEXT.AND.RPAR.GT.DEL*GAM) THEN + IF ((RPAR-DEL*GAM)**2.GE.(DEL-DEL*GAM)**2) THEN + ENERGY = ENERGY + HUGE(1D0) + ELSE + ENERGY = ENERGY - EPAR*CHAINP%FINITSHEAR/2*DEL*(1-GAM)**2* & + & LOG(1-(RPAR-DEL*GAM)**2/(DEL-DEL*GAM)**2) + ENERGY = ENERGY + EPAR*(1-CHAINP%FINITSHEAR)/2/DEL* & + & (RPAR-DEL*GAM)**2 + ENDIF + ELSE + ENERGY = ENERGY + EPAR/2/DEL*(RPAR - DEL*GAM)**2 + ENDIF + ENDIF + + IF (CHAINP%SHEARABLE) THEN + IF (CHAINP%FINITEXT) THEN + IF (RPAR**2+RPERP2.GT.DEL**2) THEN + ENERGY = ENERGY + HUGE(1D0) + RETURN + ENDIF + RMAX2 = DEL**2-RPAR**2; + ENERGY = ENERGY - EPERP*CHAINP%FINITSHEAR/2/DEL*RMAX2*LOG(1-(RPERP2)/RMAX2) + ENERGY = ENERGY + EPERP*(1-CHAINP%FINITSHEAR)/2/DEL*(RPERP2) + ELSE + ENERGY = ENERGY + EPERP/2/DEL*(RPERP2) + ENDIF + + IF (CHAINP%COUPLED) THEN + ENERGY = ENERGY + EC/DEL*DOT_PRODUCT(RPERP,DU) + ENDIF + ENDIF + + END SUBROUTINE GETBEADENERGY + +! ------------ SETUP FUNCTIONS --------------- + SUBROUTINE INITIALIZECHAIN(CHAINP,RANDOMIZE,RANDMAG) + ! initialize chain configuration, straight in the z direction or random + USE mt19937, ONLY : GRND + USE QUATUTIL, ONLY : ROTANGAX + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + LOGICAL, INTENT(IN) :: RANDOMIZE + DOUBLE PRECISION, INTENT(IN), OPTIONAL :: RANDMAG(2) + INTEGER :: N , B + DOUBLE PRECISION :: ENERGY + DOUBLE PRECISION :: RVEC(3), AX(3), THETA,ROTMAT(3,3) + + IF (RANDOMIZE.AND..NOT.PRESENT(RANDMAG)) THEN + PRINT*, 'ERROR IN INITIALIZECHAIN: no randomize magnitude supplied' + STOP 1 + ENDIF + + IF (RANDOMIZE) THEN + ! Randomly perturb configuration + DO B = 1,CHAINP%NPT + RVEC = (/GRND(),GRND(),GRND()/)*2*RANDMAG(1) - (/1,1,1/)*RANDMAG(1) + IF (B.EQ.1) THEN + CHAINP%POS(:,B) = RVEC + ELSE + IF (.NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + ! make sure segment length is correct + RVEC = (/0D0,0D0,CHAINP%LS(B-1)*CHAINP%GAM(B-1)/)+RVEC + RVEC = RVEC/SQRT(SUM(RVEC**2))*CHAINP%LS(B-1)*CHAINP%GAM(B-1) + CHAINP%POS(:,B) = CHAINP%POS(:,B-1)+RVEC + ELSE + CHAINP%POS(:,B) = CHAINP%POS(:,B-1)+& + &(/0D0,0D0,CHAINP%LS(B-1)*CHAINP%GAM(B-1)/)+RVEC + ENDIF + ENDIF + + ! random axis + AX = (/GRND(),GRND(),GRND()/) + AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + ! random theta + THETA = GRND()*RANDMAG(2) + CALL ROTANGAX(THETA,AX,(/0D0,0D0,1D0/),CHAINP%UVEC(:,B),.TRUE.,ROTMAT) + END DO + ELSE + ! set up a straight chain + CHAINP%POS(1:2,:) = 0D0; + CHAINP%POS(3,1) = 0D0; + DO B = 2,CHAINP%NPT + CHAINP%POS(3,B) = CHAINP%POS(3,B-1)+CHAINP%LS(B-1)*CHAINP%GAM(B-1) + ENDDO + CHAINP%UVEC = 0D0 + CHAINP%UVEC(3,:) = 1D0 + END IF + + ! Coords for brownian dynamics + ! DO B = 1,CHAINP%NPT + ! CHAINP%COORDS(6*(B-1)+1:6*(B-1)+3) = CHAINP%POS(:,B) + ! CHAINP%COORDS(6*(B-1)+4:6*(B-1)+6) = CHAINP%UVEC(:,B) + ! END DO + + + CALL GETENERGY(CHAINP,ENERGY) + + END SUBROUTINE INITIALIZECHAIN + + SUBROUTINE COPYCHAIN(CHAINP1,CHAINP2) + ! copy all parameters over from chainp1 to chainp2 + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP1, CHAINP2 + + IF (.NOT.CHAINP1%ARRAYSET.OR..NOT.CHAINP2%ARRAYSET) THEN + PRINT*, 'ERROR: CANNOT COPY CHAINS UNLESS BOTH HAVE INITIALIZED ARRAYS' + PRINT*, CHAINP1%ARRAYSET, CHAINP2%ARRAYSET + STOP 1 + ENDIF + + IF (CHAINP1%MAXNPT.NE.CHAINP2%MAXNPT) THEN + PRINT*, 'ERROR: CANNOT COPY CHAINS OF DIFFERENT SIZE' + stop 1 + ENDIF + + CHAINP2%LS = CHAINP1%LS + CHAINP2%STRETCHABLE = CHAINP1%STRETCHABLE + CHAINP2%SHEARABLE = CHAINP1%SHEARABLE + CHAINP2%COUPLED = CHAINP1%COUPLED + CHAINP2%LP = CHAINP1%LP + CHAINP2%GAM = CHAINP1%GAM + CHAINP2%EC = CHAINP1%EC + CHAINP2%EPERP = CHAINP1%EPERP + CHAINP2%EPAR = CHAINP1%EPAR + CHAINP2%FORCE = CHAINP1%FORCE + CHAINP2%HASFORCE = CHAINP1%HASFORCE + + CHAINP2%POS = CHAINP1%POS + CHAINP2%UVEC = CHAINP1%UVEC + CHAINP2%BEADENERGY = CHAINP1%BEADENERGY + CHAINP2%FORCEENERGY = CHAINP1%FORCEENERGY + CHAINP2%FINITEXT = CHAINP1%FINITEXT + CHAINP2%FINITSHEAR = CHAINP1%FINITSHEAR + + CHAINP2%CONSTMOD = CHAINP1%CONSTMOD + CHAINP2%DELS = CHAINP1%DELS +! CHAINP2%COORDS = CHAINP1%COORDS + CHAINP2%FRICTR = CHAINP1%FRICTR + CHAINP2%FRICTU = CHAINP1%FRICTU + + CHAINP2%STERICS = CHAINP1%STERICS + CHAINP2%STERRAD2 = CHAINP1%STERRAD2 + CHAINP2%STERRAD = CHAINP1%STERRAD + CHAINP2%STERSKIP = CHAINP2%STERSKIP + + CHAINP2%NPT = CHAINP1%NPT + CHAINP2%MAXNPT = CHAINP1%MAXNPT + CHAINP2%MINSEGLEN = CHAINP1%MINSEGLEN + CHAINP2%MAXSEGLEN = CHAINP1%MAXSEGLEN + + CHAINP2%STERMOD = CHAINP1%STERMOD + CHAINP2%STERICENERGY = CHAINP1%STERICENERGY + CHAINP2%MU = CHAINP1%MU + END SUBROUTINE COPYCHAIN + + SUBROUTINE SETOBSTACLEPARAMS(OBP) + ! set parameters for obstacle object + USE KEYS, ONLY : FRICTOB,RADOB,MODOB + IMPLICIT NONE + TYPE(OBSTACLE), POINTER :: OBP + + OBP%RAD = RADOB + OBP%MOD = MODOB + OBP%FRICT= FRICTOB + END SUBROUTINE SETOBSTACLEPARAMS + + SUBROUTINE SETCHAINPARAMS(CHAINP,FORCE) + ! set parameters for the chain using keywords from KEYS module + USE KEYS, ONLY : LS, SHEARABLE,STRETCHABLE,COUPLED,LP,EC,EPERP,& + & EPAR,GAM,FINITEXT, FINITSHEAR, CONSTMOD,FRICTR,FRICTU,& + & USESTERICS, STERRAD, STERSKIP, STARTNPT,MINSEGLEN,MAXSEGLEN,STERMOD,& + & MU,NFIXBEAD,FIXBEAD, NEDGESEG, EDGELS, EDGELP, EDGEGAM, EDGEEPERP,& + & EDGEEPAR,EDGEEC, FRICTPERLEN + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN), OPTIONAL :: FORCE + INTEGER :: I, b + + CHAINP%NPT = STARTNPT + CHAINP%NFIXBEAD = NFIXBEAD + IF (.NOT.CHAINP%ARRAYSET.AND.NFIXBEAD.GT.0) THEN + PRINT*, 'ERROR IN SETCHAINPARAMS. ARRAYS HAVE NOT BEEN SET.' + STOP 1 + ENDIF + IF (NFIXBEAD.GT.0) THEN + CHAINP%FIXBEAD(1:NFIXBEAD) = FIXBEAD(1:NFIXBEAD,1) + DO I = 1,NFIXBEAD + IF (CHAINP%FIXBEAD(I).LT.1.OR.CHAINP%FIXBEAD(I).GT.CHAINP%NPT) THEN + PRINT*, 'ERROR: BAD FIXBEAD', CHAINP%FIXBEAD(I) + STOP 1 + ENDIF + CHAINP%ISFIXED(CHAINP%FIXBEAD(I)) = .TRUE. + ENDDO + ENDIF + CHAINP%LS = LS + CHAINP%DELS = LS + CHAINP%STRETCHABLE = STRETCHABLE + CHAINP%SHEARABLE = SHEARABLE + CHAINP%COUPLED = COUPLED + CHAINP%LP = LP + CHAINP%GAM = GAM + CHAINP%EC = EC + CHAINP%EPERP = EPERP + CHAINP%EPAR = EPAR + IF (NEDGESEG.GT.0) THEN + DO B = 1,NEDGESEG + CHAINP%LS(B) = EDGELS + CHAINP%DELS(B) = EDGELS + CHAINP%LP(B) = EDGELP + CHAINP%GAM(B) = EDGEGAM + CHAINP%EC(B) = EDGEEC + CHAINP%EPERP(B) = EDGEEPERP + CHAINP%EPAR(B) = EDGEEPAR + END DO + DO B = CHAINP%NPT-NEDGESEG,CHAINP%NPT-1 + CHAINP%LS(B) = EDGELS + CHAINP%DELS(B) = EDGELS + CHAINP%LP(B) = EDGELP + CHAINP%GAM(B) = EDGEGAM + CHAINP%EC(B) = EDGEEC + CHAINP%EPERP(B) = EDGEEPERP + CHAINP%EPAR(B) = EDGEEPAR + END DO + ENDIF + + IF (PRESENT(FORCE)) THEN + CHAINP%FORCE = FORCE + CHAINP%HASFORCE = .TRUE. + ELSE + CHAINP%FORCE = 0D0 + ENDIF + CHAINP%FINITEXT = FINITEXT + CHAINP%FINITSHEAR = FINITSHEAR + CHAINP%CONSTMOD = CONSTMOD + IF (FRICTPERLEN) THEN + ! keyword parameters are friction per unit length + ! different friction for edge beads; different friction if different segment lengths + CHAINP%FRICTR(1) = FRICTR*CHAINP%LS(1)/2 + CHAINP%FRICTU(1) = FRICTU*CHAINP%LS(1) + CHAINP%FRICTR(CHAINP%NPT) = FRICTR*CHAINP%LS(CHAINP%NPT-1)/2 + CHAINP%FRICTU(CHAINP%NPT) = FRICTU*CHAINP%LS(CHAINP%NPT-1) + DO B = 2,CHAINP%NPT-1 + CHAINP%FRICTR(B) = FRICTR*(CHAINP%LS(B-1)/2+CHAINP%LS(B)/2) + CHAINP%FRICTU(B) = FRICTU*CHAINP%LS(B) + ENDDO + ELSE + ! keyword parameters are just the friction for each bead + CHAINP%FRICTR = FRICTR + CHAINP%FRICTU = FRICTU + ENDIF + CHAINP%STERICS = USESTERICS + CHAINP%STERRAD = STERRAD + CHAINP%STERRAD2 = STERRAD*STERRAD + CHAINP%STERSKIP = STERSKIP + CHAINP%MINSEGLEN = MINSEGLEN + CHAINP%MAXSEGLEN = MAXSEGLEN + CHAINP%STERMOD = STERMOD + CHAINP%MU = MU + + END SUBROUTINE SETCHAINPARAMS + + SUBROUTINE SETUPCHAIN(CHAINP,MAXNPT) + USE KEYS, ONLY : MAXFIXBEAD + ! set up the arrays for a chain object + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: maxNPT + + CHAINP%MAXNPT = MAXNPT + CHAINP%HASFORCE = .FALSE. + + ALLOCATE(CHAINP%POS(3,MAXNPT),CHAINP%UVEC(3,MAXNPT),CHAINP%BEADENERGY(MAXNPT)) + + ALLOCATE(CHAINP%LP(MAXNPT-1),CHAINP%LS(MAXNPT-1), CHAINP%EPAR(MAXNPT-1), & + & CHAINP%EPERP(MAXNPT-1), CHAINP%EC(MAXNPT-1), CHAINP%GAM(MAXNPT-1)) + +! CHAINP%NCRD = MAXNPT*6 +! ALLOCATE(CHAINP%COORDS(CHAINP%NCRD)) + ALLOCATE(CHAINP%DELS(MAXNPT-1),CHAINP%FIXBEAD(MAXFIXBEAD),CHAINP%ISFIXED(MAXNPT)) + + ALLOCATE(CHAINP%FRICTR(MAXNPT),CHAINP%FRICTU(MAXNPT)) + + CHAINP%BEADENERGY = 0D0 + CHAINP%STERICENERGY=0D0 + CHAINP%ISFIXED = .FALSE. + CHAINP%NFIXBEAD = 0 + CHAINP%ARRAYSET = .TRUE. + END SUBROUTINE SETUPCHAIN + + SUBROUTINE CLEANUPCHAIN(CHAINP) + ! clean up allocatable arrays for the object + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + + DEALLOCATE(CHAINP%POS,CHAINP%UVEC,CHAINP%DELS,& + & CHAINP%BEADENERGY, CHAINP%LP, CHAINP%LS, CHAINP%gam, CHAINP%EPAR, & + & CHAINP%EPERP, CHAINP%EC,CHAINP%FIXBEAD,CHAINP%ISFIXED, & + & CHAINP%FRICTR, CHAINP%FRICTU) + + END SUBROUTINE CLEANUPCHAIN +END MODULE CHAINUTIL diff --git a/BasicWLC/dssWLC/source/cylinder.f90 b/BasicWLC/dssWLC/source/cylinder.f90 new file mode 100644 index 00000000..f0ebadbc --- /dev/null +++ b/BasicWLC/dssWLC/source/cylinder.f90 @@ -0,0 +1,334 @@ +MODULE CYLINDERUTIL + ! utilities for dealing with cylindrical sterics + USE GENUTIL + IMPLICIT NONE + +CONTAINS + LOGICAL FUNCTION CYLINDERINTERSECT(RA,RB,LA,LB,CA,NA,CB,NB) + ! check if two cylinders intersect + ! RA, RB are the radii + ! LA,LB are the cylinder lengths + ! CA,NA are the center and normalized axis of the 1st cylinder + ! CB,NB are for 2nd cylinder + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: RA, RB, LA, LB + DOUBLE PRECISION, INTENT(IN) :: CA(3), NA(3), CB(3), NB(3) + DOUBLE PRECISION :: DIST, CENTA(3),CENTB(3), CENTB2(3), TMIN + INTEGER :: I, J + LOGICAL :: INSEG1, INSEG2 + + + CYLINDERINTERSECT = .FALSE. + + ! get distance between line segments + CALL LINESEGDIST(NA,CA,NB,CB,LA,LB,DIST,INSEG1,INSEG2) + + IF (DIST.GT.(RA+RB)**2) then + RETURN ! lower bound is above 0 + ELSE IF (INSEG1.AND.INSEG2) THEN + CYLINDERINTERSECT = .TRUE. ! shells intersect + RETURN + ENDIF + + + DO I = -1,1,2 + ! check if axis B crosses any disc on A + CENTA = CA + I*NA*LA/2 + CYLINDERINTERSECT = LINEDISCINTERSECT(RA,CENTA,NA,NB,CB,LB) + IF (CYLINDERINTERSECT) RETURN + + ! check if axis A crosses any disc on B + CENTB = CB + I*NB*LB/2 + CYLINDERINTERSECT = LINEDISCINTERSECT(RB,CENTB,NB,NA,CA,LA) + + IF (CYLINDERINTERSECT) RETURN + + ! check if any pair of discs intersects + DO J = -1,1,2 + CENTB2 = CB + J*NB*LB/2 + + CYLINDERINTERSECT = DISCDISCINTERSECT(RA,CENTA,NA,RB,CENTB2,NB) + IF (CYLINDERINTERSECT) RETURN + ENDDO + + ! check for circle-shell intersections + ! get distance between circle A and axis B + CALL CIRCLELINEDIST(RA,CENTA,NA,NB,CB,DIST,TMIN) + IF (DIST.LT.RB*RB.AND.ABS(TMIN).LT.LB/2) THEN + CYLINDERINTERSECT = .TRUE.; RETURN + ENDIF + + ! get distance between circle B and axis A + CALL CIRCLELINEDIST(RB,CENTB,NB,NA,CA,DIST,TMIN) + IF (DIST.LT.RA*RA.AND.ABS(TMIN).LT.LA/2) THEN + CYLINDERINTERSECT = .TRUE.; RETURN + ENDIF + ENDDO + + END FUNCTION CYLINDERINTERSECT + + LOGICAL FUNCTION LINEDISCINTERSECT(RD,CD,ND,M,B,L) + ! check if a line intersects a disc + ! RD, CD, ND are radius, center and normal of disc + ! line is M*T+B; length of line is L + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: CD(3), ND(3), M(3), B(3),L,RD + DOUBLE PRECISION :: T, BC(3), PT(3) + + ! get point where line passes through disc plane + BC = B-CD + T = -DOT_PRODUCT(BC,ND)/DOT_PRODUCT(M,ND) + + LINEDISCINTERSECT = .FALSE. + IF (ABS(T).LE.L/2) THEN + ! check distance of intersection from disc center + PT = M*T + BC + IF (DOT_PRODUCT(PT,PT).LE.RD*RD) THEN + LINEDISCINTERSECT = .TRUE. + ENDIF + ENDIF + + END FUNCTION LINEDISCINTERSECT + + LOGICAL FUNCTION DISCDISCINTERSECT(RA,CA,NA,RB,CB,NB) + ! check if two discs intersect + ! assume na, nb are normalized + IMPLICIT NONE + DOUBLE PRECISION :: RA, RB, CA(3), NA(3), CB(3), NB(3) + DOUBLE PRECISION, PARAMETER :: TINY = 1D-10 + DOUBLE PRECISION :: CBA(3), V(3), U(3), ST, CT, DIFF(3) + double precision :: DIST, T,PT1(3) + + DISCDISCINTERSECT = .FALSE. + CBA = CB-CA + + IF (DOT_PRODUCT(CBA,CBA).GT.(RA+RB)**2) RETURN + + IF (ABS(ABS(DOT_PRODUCT(NA,NB))-1).LT.TINY) THEN + ! discs are parallel + DISCDISCINTERSECT = ABS(DOT_PRODUCT(CBA,NA)).LT.TINY + ELSE + ! consider case where circle A passes through disc B + CALL CROSS_PRODUCT(NA,NB,U); U = U/NORM(U) + CALL CROSS_PRODUCT(NA,U,V); + + ST = DOT_PRODUCT(CBA,NB)/RA/DOT_PRODUCT(V,NB) + IF (ABS(ST).GT.1) RETURN ! circle never passes through plane of disc + CT = SQRT(1-ST**2) + + IF (CT.EQ.0D0) THEN + ! circle A only hits disc B at one point + PT1 = RA*CT*U + RA*ST*V -CBA + DISCDISCINTERSECT = DOT_PRODUCT(PT1,PT1).LE.RB*RB + RETURN + ENDIF + + PT1 = -RA*CT*U + RA*ST*V +CA + DIFF = 2*RA*CT*U + + ! check if each relevant endpoint on circle A is within the disc + ! and otherwise, whether some point on the line between them is within the disc + IF (DOT_PRODUCT(PT1-CB,PT1-CB).LE.RB*RB) THEN + DISCDISCINTERSECT = .TRUE.; RETURN + ELSEIF (DOT_PRODUCT(PT1+DIFF-CB,PT1+DIFF-CB).LE.RB*RB) THEN + DISCDISCINTERSECT = .TRUE.; RETURN + ELSE + calL ptlinedist(cb,diff,pt1,DIST,T) + IF (DIST.LE.RB*RB.AND.T.LT.1.AND.T.GT.0) THEN + DISCDISCINTERSECT = .TRUE.; RETURN + ENDIF + ENDIF + + ENDIF + END FUNCTION DISCDISCINTERSECT + + SUBROUTINE PTLINEDIST(PT,M,B,DIST,T) + ! give the squared distance between a point and a line + ! and the position on the line L = M*t + B where the distance vector hits + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: PT(3), M(3),B(3) + DOUBLE PRECISION, INTENT(OUT) :: DIST, T + DOUBLE PRECISION :: DIFF(3) + + T = DOT_PRODUCT(M,PT-B)/DOT_PRODUCT(M,M) + DIFF = M*T+B-PT + DIST = DOT_PRODUCT(DIFF,DIFF) + + END SUBROUTINE PTLINEDIST + + SUBROUTINE LINESEGDIST(M,B,U,V,LENA,LENB,DIST,INSEG1,INSEG2) + ! calculate the minimal squared distance between 2 line segments + ! line segment 1 has center B, slope M, length LENA + ! line segment 2 has center V, slope U, length LENB + ! INSEG is true if the points at minimal separation fall within (not at ends) of each segment + ! see cylinder-cylinder notes from 10/19/2009 + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: M(3), B(3),U(3), V(3),LENA,LENB + DOUBLE PRECISION, INTENT(OUT) :: DIST + LOGICAL, INTENT(OUT) :: INSEG1,INSEG2 + DOUBLE PRECISION :: BV(3), UU, UM, MM, MBV, TMP, T, S, DIFF(3) + DOUBLE PRECISION :: Z, CMP, SMM, SUU + + INSEG1 = .FALSE.; INSEG2 = .FALSE. + BV = B - V + UU = DOT_PRODUCT(U,U) + UM = DOT_PRODUCT(U,M) + MM = DOT_PRODUCT(M,M) + MBV = DOT_PRODUCT(M,BV) + + IF (UM.EQ.0D0) THEN + ! lines are perpendicular + T = MBV/MM + S = DOT_PRODUCT(U,BV)/UU + ELSE + TMP = (UM-UU*MM/UM) + IF (ABS(TMP).LT.EPSILON(1D0)) THEN + ! lines are parallel and do not intersect + ! T = -MBV/MM + ! INSEG2 = .TRUE. + ! INSEG1 = ABS(T).LT.LENA/2 + ! DIST = DOT_PRODUCT(M*T+BV,M*T+BV) + + SMM = SQRT(MM); SUU = SQRT(UU) + Z = -MBV/SMM + CMP = SMM*LENA/2 + SUU*LENB/2 + + IF (ABS(Z).LT.CMP) THEN + ! distance btwn segments is distance btwn lines + DIST = DOT_PRODUCT(BV,BV)-Z*Z + INSEG1 = .TRUE.; INSEG2 = .TRUE. + ELSE ! segments are offset + T = SIGN(LENA/2,Z) + S = -SIGN(LENB/2,Z) + IF (UM.LT.0) THEN ! segments are oppositely oriented + ! flip which endpoint to use on 2nd segment + S = -S + ENDIF + DIFF = M*T-U*S+BV + DIST = DOT_PRODUCT(DIFF,DIFF) + ENDIF + RETURN + ENDIF + + T= (UU/UM*MBV-DOT_PRODUCT(BV,U))/TMP + S = (MM*T + MBV)/UM + ENDIF + + INSEG1 = ABS(T).LT.LENA/2 + IF (.NOT.INSEG1) THEN + T = SIGN(LENA/2,T-LENA/2) + CALL PTLINEDIST(M*T + B,U,V,DIST,S) + ENDIF + + INSEG2 = ABS(S).LT.LENB/2 + IF (.NOT.INSEG2) THEN + S = SIGN(LENB/2,S-LENB/2) + CALL PTLINEDIST(U*S + V,M,B,DIST,T) + ENDIF + + INSEG1 = ABS(T).LT.LENA/2 + IF (.NOT.INSEG1) THEN + T = SIGN(LENA/2,T-LENA/2) + ENDIF + + DIFF = M*T + B - U*S - V + DIST = DOT_PRODUCT(DIFF,DIFF) + END SUBROUTINE LINESEGDIST + + SUBROUTINE CIRCLELINEDIST(RA,CA,NA,MV,BV,DIST,TMIN) + ! minimial squared distance between a circle of radius RA, centered at CA + ! with normal (normalized) given by NA + ! and the line L(t) = MV*t + BV + ! also return the point at which minimal distance happens + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: CA(3), NA(3), MV(3), BV(3), RA + DOUBLE PRECISION, INTENT(OUT) :: DIST + DOUBLE PRECISION :: A0,A1,A2,A3,A4,A5,A6,ACOEFF(7) + DOUBLE PRECISION :: DV(3), EV(3), FV(3) + DOUBLE PRECISION :: AX, BX, CX, TMIN, FA, FD, DFC, DFA,T + INTEGER :: TC + DOUBLE PRECISION :: DBRENT + EXTERNAL DBRENT + DOUBLE PRECISION :: C1, B0, B1, B2, B3,B4,D0,D1,D2 + DOUBLE PRECISION :: DSCR, SDSCR + + DV = BV-CA + EV = MV - DOT_PRODUCT(NA,MV)*NA + FV = DV - DOT_PRODUCT(NA,DV)*NA + + A6 = DOT_PRODUCT(MV,MV) + A5 = 2*DOT_PRODUCT(DV,MV) + A4 = DOT_PRODUCT(DV,DV) + RA**2 + A3 = -2*RA + A2 = DOT_PRODUCT(EV,EV) + A1 = 2*DOT_PRODUCT(EV,FV) + A0 = DOT_PRODUCT(FV,FV) + + ACOEFF = (/A0,A1,A2,A3,A4,A5,A6/) + + ! bracket the interval + BX = DOT_PRODUCT(CA-BV,MV)/DOT_PRODUCT(MV,MV) + AX = BX - RA; CX = BX + RA + + ! ------------- + ! get first minimum of function + ! ------------- + DIST = DBRENT(AX,BX,CX,CLFUNC,10,ACOEFF,1d-7,TMIN) + call cLfunc(TMIN,acoeff,FD,dfA) + + ! get coefficients for checking for 2nd minimum + C1 = FD-A4 + B4 = A6**2 + B3 = 2*A6*A5 + B2=A5**2 - 2*A6*C1 - A3**2*A2 + B1 = -2*A5*C1-A3**2*A1 + B0 = C1**2 - A3**2*A0 + + ! deflate to 2nd degree polynomial by dividing by the double root + D2 = B4 + D1 = B3 + 2*B4*TMIN + D0 = B2+3*B4*TMIN**2+2*B3*TMIN + + ! find roots of 2nd degree polynomial (if it exists); use this to bracket + DSCR = D1**2 - 4*D0*D2 + IF (DSCR.GT.0D0) THEN + SDSCR = SQRT(DSCR) + IF (D2.GT.0) THEN + AX = (-D1 - SDSCR)/(2*D2) + CX = (-D1 + SDSCR)/(2*D2) + ELSE + AX = (-D1 + SDSCR)/(2*D2) + CX = (-D1 - SDSCR)/(2*D2) + ENDIF + BX = (AX+CX)/2 + + ! get 2nd minimum + DIST = DBRENT(AX,BX,CX,CLFUNC,10,ACOEFF,1d-7,TMIN) + + endif + + END SUBROUTINE CIRCLELINEDIST + + SUBROUTINE CLFUNC(T,ACOEFF,F,DF) + ! get the squared distance btwn a circle and a line using precalculated coefficients + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: T,ACOEFF(:) + DOUBLE PRECISION, INTENT(OUT) :: F, DF + DOUBLE PRECISION :: TMP + + TMP = ACOEFF(3)*T**2 + ACOEFF(2)*T+ACOEFF(1) + + IF (TMP.LT.-100*EPSILON(1D0)) THEN + PRINT*, 'ERROR IN CLFUNC: bad value inside square root', TMP + STOP + ELSE + TMP = SQRT(MAX(0D0,TMP)) + ENDIF + + F = ACOEFF(7)*T**2 + ACOEFF(6)*T + ACOEFF(5) + ACOEFF(4)*TMP + DF = 2*ACOEFF(7)*T + ACOEFF(6) + ACOEFF(4)/2*(2*ACOEFF(3)*T + ACOEFF(2))/TMP + + END SUBROUTINE CLFUNC +END MODULE CYLINDERUTIL diff --git a/BasicWLC/dssWLC/source/dbrent.f90 b/BasicWLC/dssWLC/source/dbrent.f90 new file mode 100644 index 00000000..664381b1 --- /dev/null +++ b/BasicWLC/dssWLC/source/dbrent.f90 @@ -0,0 +1,132 @@ +! this finds a bracketed minimum of a function FUNC +! EFK 2009/10/19: converted to use double precision +! changed from using separate func and dfunc to a subroutine that yields both +! also added a parameter array to be passed alongside + FUNCTION dbrent(ax,bx,cx,FUNC,NPARAM,PARAM,tol,xmin) + USE nrtype; USE nrutil, ONLY : nrerror + IMPLICIT NONE + INTEGER :: NPARAM + REAL(DP), INTENT(IN) :: ax,bx,cx,tol,PARAM(NPARAM) + REAL(DP), INTENT(OUT) :: xmin + REAL(DP) :: dbrent + INTERFACE + SUBROUTINE func(x,PARAM,F,DF) + USE nrtype + IMPLICIT NONE + REAL(DP), INTENT(IN) :: x,PARAM(:) + REAL(DP), INTENT(OUT) :: F, DF + END SUBROUTINE func + END INTERFACE + INTEGER(I4B), PARAMETER :: ITMAX=100 + REAL(DP), PARAMETER :: ZEPS=1.0e-3_sp*epsilon(ax) + INTEGER(I4B) :: iter + REAL(DP) :: a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw,fx,olde,tol1,tol2,& + u,u1,u2,v,w,x,xm + LOGICAL :: ok1,ok2 + + IF (TOL*TOL.LT.EPSILON(AX)) THEN + PRINT*, 'WARNING: TOL is less than sqrt(precision) in dbrent. Minimization may fail', TOL, EPSILON(AX) + ENDIF + + a=min(ax,cx) + b=max(ax,cx) + v=bx + w=v + x=v + e=0.0 + + CALL FUNC(X,PARAM,FX,DX) +! fx=func(x) + fv=fx + fw=fx +! dx=dfunc(x) + dv=dx + dw=dx + do iter=1,ITMAX + xm=0.5_sp*(a+b) + tol1=tol*abs(x)+ZEPS + tol2=2.0_sp*tol1 + if (abs(x-xm) <= (tol2-0.5_sp*(b-a))) exit + if (abs(e) > tol1) then + d1=2.0_sp*(b-a) + d2=d1 + if (dw /= dx) d1=(w-x)*dx/(dx-dw) + if (dv /= dx) d2=(v-x)*dx/(dx-dv) + u1=x+d1 + u2=x+d2 + ok1=((a-u1)*(u1-b) > 0.0) .and. (dx*d1 <= 0.0) + ok2=((a-u2)*(u2-b) > 0.0) .and. (dx*d2 <= 0.0) + olde=e + e=d + if (ok1 .or. ok2) then + if (ok1 .and. ok2) then + d=merge(d1,d2, abs(d1) < abs(d2)) + else + d=merge(d1,d2,ok1) + end if + if (abs(d) <= abs(0.5_sp*olde)) then + u=x+d + if (u-a < tol2 .or. b-u < tol2) & + d=sign(tol1,xm-x) + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + !print*, 'testxc:', d, tol1 + if (abs(d) >= tol1) then + u=x+d + CALL FUNC(U,PARAM,FU,DU) + !fu=func(u) + else + u=x+sign(tol1,d) + CALL FUNC(U,PARAM,FU,DU) + !fu=func(u) + if (fu > fx) exit + end if + ! print*, 'testxbb:', u, fu, du, fx, iter + !du=dfunc(u) + if (fu <= fx) then + if (u >= x) then + a=x + else + b=x + end if + call mov3(v,fv,dv,w,fw,dw) + call mov3(w,fw,dw,x,fx,dx) + call mov3(x,fx,dx,u,fu,du) + else + if (u < x) then + a=u + else + b=u + end if + if (fu <= fw .or. w == x) then + call mov3(v,fv,dv,w,fw,dw) + call mov3(w,fw,dw,u,fu,du) + else if (fu <= fv .or. v == x .or. v == w) then + call mov3(v,fv,dv,u,fu,du) + end if + end if + end do + ! print*, 'iter:', iter + if (iter > ITMAX) call nrerror('dbrent: exceeded maximum iterations') + xmin=x + dbrent=fx + CONTAINS +!BL + SUBROUTINE mov3(a,b,c,d,e,f) + REAL(DP), INTENT(IN) :: d,e,f + REAL(DP), INTENT(OUT) :: a,b,c + a=d + b=e + c=f + END SUBROUTINE mov3 + END FUNCTION dbrent diff --git a/BasicWLC/dssWLC/source/dgtsl.f b/BasicWLC/dssWLC/source/dgtsl.f new file mode 100644 index 00000000..710326f5 --- /dev/null +++ b/BasicWLC/dssWLC/source/dgtsl.f @@ -0,0 +1,119 @@ + subroutine dgtsl(n,c,d,e,b,info) + integer n,info + double precision c(1),d(1),e(1),b(1) +c +c dgtsl given a general tridiagonal matrix and a right hand +c side will find the solution. +c +c on entry +c +c n integer +c is the order of the tridiagonal matrix. +c +c c double precision(n) +c is the subdiagonal of the tridiagonal matrix. +c c(2) through c(n) should contain the subdiagonal. +c on output c is destroyed. +c +c d double precision(n) +c is the diagonal of the tridiagonal matrix. +c on output d is destroyed. +c +c e double precision(n) +c is the superdiagonal of the tridiagonal matrix. +c e(1) through e(n-1) should contain the superdiagonal. +c on output e is destroyed. +c +c b double precision(n) +c is the right hand side vector. +c +c on return +c +c b is the solution vector. +c +c info integer +c = 0 normal value. +c = k if the k-th element of the diagonal becomes +c exactly zero. the subroutine returns when +c this is detected. +c +c linpack. this version dated 08/14/78 . +c jack dongarra, argonne national laboratory. +c +c no externals +c fortran dabs +c +c internal variables +c + integer k,kb,kp1,nm1,nm2 + double precision t +c begin block permitting ...exits to 100 +c + info = 0 + c(1) = d(1) + nm1 = n - 1 + if (nm1 .lt. 1) go to 40 + d(1) = e(1) + e(1) = 0.0d0 + e(n) = 0.0d0 +c + do 30 k = 1, nm1 + kp1 = k + 1 +c +c find the largest of the two rows +c + if (dabs(c(kp1)) .lt. dabs(c(k))) go to 10 +c +c interchange row +c + t = c(kp1) + c(kp1) = c(k) + c(k) = t + t = d(kp1) + d(kp1) = d(k) + d(k) = t + t = e(kp1) + e(kp1) = e(k) + e(k) = t + t = b(kp1) + b(kp1) = b(k) + b(k) = t + 10 continue +c +c zero elements +c + if (c(k) .ne. 0.0d0) go to 20 + info = k +c ............exit + go to 100 + 20 continue + t = -c(kp1)/c(k) + c(kp1) = d(kp1) + t*d(k) + d(kp1) = e(kp1) + t*e(k) + e(kp1) = 0.0d0 + b(kp1) = b(kp1) + t*b(k) + 30 continue + 40 continue + if (c(n) .ne. 0.0d0) go to 50 + info = n + go to 90 + 50 continue +c +c back solve +c + nm2 = n - 2 + b(n) = b(n)/c(n) + if (n .eq. 1) go to 80 + b(nm1) = (b(nm1) - d(nm1)*b(n))/c(nm1) + if (nm2 .lt. 1) go to 70 + do 60 kb = 1, nm2 + k = nm2 - kb + 1 + b(k) = (b(k) - d(k)*b(k+1) - e(k)*b(k+2))/c(k) + 60 continue + 70 continue + 80 continue + 90 continue + 100 continue +c + return + end diff --git a/BasicWLC/dssWLC/source/genutil.f90 b/BasicWLC/dssWLC/source/genutil.f90 new file mode 100644 index 00000000..ae7ebcef --- /dev/null +++ b/BasicWLC/dssWLC/source/genutil.f90 @@ -0,0 +1,279 @@ +MODULE GENUTIL + ! generally useful utilities + USE MT19937 ! mersenne random number generator + USE QUATUTIL ! utilities for dealing with quaternions + + IMPLICIT NONE + +CONTAINS + + INTEGER FUNCTION STRING2NUM(STRINGIN,APPENDNUM) + ! convert the string to a unique number based on ascii characters + ! the characters SPACE, {,},(,),[,],",`,<,> and all nonprintable characters are ignored + ! at most the last five characters (ignoring the unacceptable characters above) at the end of the string are used + ! any leading "!" do not affect the final number (these map to 0) + ! if APPENDNUM is specificied, only use the last 4 characters of the string as well as the additional number modulo 84 + + IMPLICIT NONE + CHARACTER(LEN=*) :: STRINGIN + CHARACTER(LEN=5) :: STRING + INTEGER, OPTIONAL :: APPENDNUM + INTEGER :: DIGARRAY(5) + INTEGER :: ALLOWED(84) + INTEGER :: N, I, D, COUNT + CHARACTER*84 :: ALLOWEDSTR + + ! set the allowed characters + ALLOWED(1:6) = (/33,35,36,37,38,39/) + ALLOWED(7:24) = (/(I,I=42,59)/) + ALLOWED(25:27) = (/61,63,64/) + ALLOWED(28:53) = (/(I, I=65,90)/) + ALLOWED(54:56) = (/92,94,95/) + ALLOWED(57:82) = (/(I, I=97,122)/) + ALLOWED(83:84) = (/124,126/) + + N = LEN(STRINGIN) + IF (PRESENT(APPENDNUM)) THEN + STRING(1:4) = STRINGIN(N-3:N) + STRING(5:5) = ACHAR(ALLOWED(MOD(APPENDNUM,84)+1)) + ELSE + STRING = STRINGIN(N-4:N) + ENDIF + N = 5 + + + DO I = 1,84 + ALLOWEDSTR(I:I) = ACHAR(ALLOWED(I)) + ENDDO + + DIGARRAY = 0 + COUNT = 0 + DO I = 0,N-1 + D = INDEX(ALLOWEDSTR,STRING(N-I:N-I),.FALSE.) + IF (D.EQ.0) THEN + print*, 'Ignoring character:', D + CYCLE + ENDIF + + DIGARRAY(5-COUNT) = D-1 + COUNT = COUNT + 1 + IF (COUNT.GE.5) EXIT + ENDDO + + STRING2NUM = BASE2DEC(DIGARRAY,5,84) + END FUNCTION STRING2NUM + + INTEGER FUNCTION BASE2DEC(DIGARRAY,N,BASE) + ! given a number in some integer base (specified as a list of digits) + ! convert that number to a decimal integer + ! N is the size of the list + ! if resulting number is too large, wrap around to negative numbers + ! starting from the right, only use as many of the digits as + ! will fit into the resulting integer between -HUGE and HUGE + ! if any digit is greater than base-1, print error and stop + + IMPLICIT NONE + INTEGER, DIMENSION(N) :: DIGARRAY + INTEGER, INTENT(IN) :: N, BASE + INTEGER :: MAXDIG, I, D + + MAXDIG = INT(LOG(2*DBLE(HUGE(BASE))+2)/LOG(DBLE(BASE))) + + BASE2DEC = 0 + DO I = 0, MIN(N-1,MAXDIG-1) + D = DIGARRAY(N-I) + IF (D.EQ.0) CYCLE + IF (D.GT.BASE-1) THEN + PRINT*, 'ERROR in BASE2DEC: digit is bigger than base.', I, D, BASE + STOP 1 + ENDIF + + BASE2DEC = BASE2DEC + D*BASE**I + ENDDO + + END FUNCTION BASE2DEC + + SUBROUTINE INTERPARRAY(ARRAY,NA,COL,VAL,IND,INTERP) + ! for an 2D array with dimensions NA + ! use the values in column COL to interpolate for the value VAL + ! return the index IND such that ARRAY(IND,COL)GROUP2 + MAXNPT = CGRP%CHAINS(1)%MAXNPT + CALL SETUPCHAINGROUP(CGRP2,CGRP%NCHAIN,CGRP%NCONNECT,CGRP%NFORCE,MAXNPT) + CALL COPYCHAINGROUP(CGRP,CGRP2) + + + NUMSAVE=0 + + OPEN(UNIT=11,FILE=INFILE,STATUS='OLD') + COMPLETE = .FALSE.; SUCCESS = .FALSE. + DO + READ(11,'(A,1X,2I12)',IOSTAT=ICHECK) CDUM,NCHAIN,NUM + + IF (ICHECK.LT.0) exit ! end of file + + IF (NCHAIN.NE.CGRP%NCHAIN) THEN + PRINT*, 'ERROR IN READSNAPSHOT: wrong number of chains', NCHAIN, CGRP%NCHAIN + STOP 1 + ENDIF + + DO C = 1,NCHAIN + CHAINP=>CGRP%CHAINS(C) + READ(11,'(A,1X,I12)',IOSTAT=ICHECK) CDUM,NBEAD + IF (NBEAD.GT.CHAINP%MAXNPT) THEN + PRINT*, 'ERROR IN READSNAPSHOT: too many beads', NBEAD, CHAINP%MAXNPT + STOP 1 + ELSE + CHAINP%NPT = NBEAD + ENDIF + + IF (ICHECK.LT.0) exit ! end of file + + + COMPLETE = .TRUE. + DO B = 1,CHAINP%NPT + READ(11, '(A,1X,12G20.10)',IOSTAT=ICHECK) CDUM, CHAINP%POS(:,B),CHAINP%UVEC(:,B), TMPVEC + + IF (ICHECK.LT.0) THEN + print*, 'bad structure: stopping read.', b + COMPLETE = .FALSE. + EXIT ! end of file + ENDIF + IF (CDUM.NE.'A') THEN + PRINT*, 'ERROR IN READSNAPSHOT: bad beadline', CDUM + stop 2 + ENDIF + + IF (B.LT.CHAINP%NPT.AND.GETPARAM) THEN + CHAINP%LS(B) = TMPVEC(1) + CHAINP%LP(B) = TMPVEC(2) + CHAINP%GAM(B) = TMPVEC(3) + CHAINP%EPAR(B) = TMPVEC(4) + CHAINP%EPERP(B) = TMPVEC(5) + CHAINP%EC(B) = TMPVEC(6) + ENDIF + ENDDO + IF (.NOT.COMPLETE) EXIT + ENDDO + + IF (COMPLETE) THEN + SUCCESS = .TRUE. + CALL COPYCHAINGROUP(CGRP,CGRP2) + ELSE + ! incomplete structure; revert to previous one + CALL COPYCHAINGROUP(CGRP2,CGRP) + NUM = NUMSAVE + EXIT + ENDIF + ENDDO + + IF (.NOT.SUCCESS) NUM=0 + CLOSE(11) + + CALL CLEANUPCHAINGROUP(CGRP2) + END SUBROUTINE READSNAPSHOTS + + SUBROUTINE READSNAPSHOTSold(CHAINP,INFILE,NUM,SUCCESS) + ! read in a snapshot file + ! set the chain configuration to the last complete snapshot + ! NUM is the additional saved number for the last snapshot (ie: MC step) + ! chainp must be initialized and have all params set already + ! COMPLETE indicates whether a complete structure was successfully read + ! if not successful, coords remain unchanged + USE CHAINUTIL, ONLY : CHAIN + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + CHARACTER(LEN=*), INTENT(IN) :: INFILE + INTEGER, INTENT(OUT) :: NUM + LOGICAL, INTENT(OUT) :: SUCCESS + DOUBLE PRECISION :: POSSAVE(3,CHAINP%MAXNPT), UVECSAVE(3,CHAINP%MAXNPT) + INTEGER :: NUMSAVE + LOGICAL :: COMPLETE + INTEGER :: B + CHARACTER :: CDUM + DOUBLE PRECISION :: DUM1, DUM2, TMPVEC(6) + INTEGER :: NBEAD, ICHECK + + POSSAVE = CHAINP%POS; UVECSAVE = CHAINP%UVEC + NUMSAVE=0 + + OPEN(UNIT=11,FILE=INFILE,STATUS='OLD') + COMPLETE = .FALSE.; SUCCESS = .FALSE. + DO + READ(11,'(A,1X,2I12,2G20.10)',IOSTAT=ICHECK) CDUM,NBEAD,NUM,DUM1,DUM2 + + IF (ICHECK.LT.0) exit ! end of file + + IF (NBEAD.GT.CHAINP%MAXNPT) THEN + PRINT*, 'ERROR IN READSNAPSHOT: too many beads', NBEAD, CHAINP%MAXNPT + STOP 1 + ELSE + CHAINP%NPT = NBEAD + ENDIF + + COMPLETE = .TRUE. + DO B = 1,CHAINP%NPT + READ(11, '(A,1X,12G20.10)',IOSTAT=ICHECK) CDUM, CHAINP%POS(:,B),CHAINP%UVEC(:,B), TMPVEC +! print*, 'testx1:', icheck, b + IF (ICHECK.LT.0) THEN + print*, 'bad structure: stopping read.', b + COMPLETE = .FALSE. + EXIT ! end of file + ENDIF + IF (CDUM.NE.'A') THEN + PRINT*, 'ERROR IN READSNAPSHOT: bad beadline', CDUM + stop 2 + ENDIF + + IF (B.LT.CHAINP%NPT) THEN + CHAINP%LS(B) = TMPVEC(1) + CHAINP%LP(B) = TMPVEC(2) + CHAINP%GAM(B) = TMPVEC(3) + CHAINP%EPAR(B) = TMPVEC(4) + CHAINP%EPERP(B) = TMPVEC(5) + CHAINP%EC(B) = TMPVEC(6) + ENDIF + ENDDO + + IF (COMPLETE) THEN + SUCCESS = .TRUE. + POSSAVE = CHAINP%POS; UVECSAVE = CHAINP%UVEC; NUMSAVE = NUM + ELSE + ! incomplete structure; revert to previous one + CHAINP%POS = POSSAVE + CHAINP%UVEC = UVECSAVE + NUM = NUMSAVE + EXIT + ENDIF + ENDDO + + IF (.NOT.SUCCESS) NUM=0 + CLOSE(11) + + END SUBROUTINE READSNAPSHOTSOLD +END MODULE INPUTUTIL diff --git a/BasicWLC/dssWLC/source/keys.f90 b/BasicWLC/dssWLC/source/keys.f90 new file mode 100644 index 00000000..9a172599 --- /dev/null +++ b/BasicWLC/dssWLC/source/keys.f90 @@ -0,0 +1,84 @@ +MODULE KEYS + ! keyword parameters that are globally used in many different places in the code + IMPLICIT NONE + + ! -------- Other --------------- + CHARACTER*100 :: ACTION + INTEGER :: RNGSEED + LOGICAL :: VERBOSE + + ! ---------------------- + ! chain geometry and energetics + ! --------------------- + LOGICAL :: SHEARABLE, STRETCHABLE, COUPLED, FINITEXT, USESTERICS + DOUBLE PRECISION :: LP, LS, EC, EPERP, EPAR, GAM, FINITSHEAR, CONSTMOD,STERRAD + INTEGER :: STARTNPT, MAXNPT,STERSKIP + DOUBLE PRECISION :: STERMOD + INTEGER :: NEDGESEG + DOUBLE PRECISION :: EDGELS, EDGELP, EDGEGAM, EDGEEPAR, EDGEEPERP,EDGEEC + + + ! --------- Output / input------------- + CHARACTER*100 :: OUTFILE, SNAPSHOTFILE, RESTARTFILE, STRESSFILE + LOGICAL :: DUMPSNAPSHOTS, RESTART, APPENDSNAPSHOTS, STARTEQUIL + INTEGER :: SNAPSHOTEVERY, SKIPREAD, EQUILSAMPLETYPE + LOGICAL :: EQUILBEADROD, PARAMFROMSNAPSHOT + DOUBLE PRECISION :: STARTEQUILLP + + ! Monte Carlo + INTEGER :: MCPRINTFREQ, MCTOTSTEPS, MCINITSTEPS, MCSTATSTEPS,MCOUTPUTFREQ, ADJUSTEVERY + DOUBLE PRECISION :: FACCTARGET, FACCTOL, ADJUSTSCL, INITRANGE(4) + LOGICAL :: DOREDISC, OUTPUTBEADWEIGHT + DOUBLE PRECISION :: MINSEGLEN, MAXSEGLEN + INTEGER :: INTUWEIGHTNPT, INTRWEIGHTNPT + + ! brownian dynamics + DOUBLE PRECISION :: FRICTR, FRICTU, DELTSCL + LOGICAL :: FRICTPERLEN + INTEGER :: BDSTEPS, RUNGEKUTTA + LOGICAL :: LOGRTERM,FIXBEAD1,FIXBEADMID + DOUBLE PRECISION :: BDPRINTEVERY + LOGICAL :: BDPRINTLOG, GAUSSIANCHAIN, USEBDENERGY, DOBROWN, USEPSEUDOFORCE + DOUBLE PRECISION :: BRCRELAX + LOGICAL :: TRACKLOOPING + CHARACTER*100 :: LOOPFILE + DOUBLE PRECISION :: LOOPRAD + + ! obstacles + DOUBLE PRECISION :: RADOB, MODOB, FRICTOB + + double precision :: mu + + ! ------------ groups of chains ------------ + INTEGER :: NFORCE, NCONNECT, NCHAIN + INTEGER, PARAMETER :: MAXNFORCE=100 + INTEGER, PARAMETER :: MAXNCONNECT = 1000 + DOUBLE PRECISION :: FORCE(MAXNFORCE,3) + INTEGER :: FORCEBEAD(MAXNFORCE,2) + INTEGER :: CONNECTIONS(MAXNCONNECT,4) + LOGICAL :: CONNECTPOS, CONNECTUVEC, SQUARELATTICE, FIXCONNECT + DOUBLE PRECISION :: CONPOSMOD, CONUVECMOD + INTEGER :: TRACKDIST(4) ! track distance between which two points (bead&chain)? + + LOGICAL :: DIAMONDLATTICE ! set up a diamon lattice + INTEGER :: NDIAMOND(2) ! number of diamonds across and down + DOUBLE PRECISION :: WIDTHDIAMOND ! Width of each diamond initially + INTEGER :: LENDIAMOND ! number of chain segments along diamond side + + ! for each fixed bead list: bead, chain, fix position, fix orientation + ! (0 for not, >0 for yes) + INTEGER, PARAMETER :: MAXFIXBEAD = 100 + INTEGER :: NFIXBEAD + INTEGER :: FIXBEAD(MAXFIXBEAD,4) + ! fix all bead positions for top/bottom and or side boundaries + ! 1) top/bottom fixed 2) sides fixed + ! 3) fix positions 4) fix orientations + LOGICAL :: FIXBOUNDARY(4) + ! force a shear deformation + LOGICAL :: SETSHEAR + DOUBLE PRECISION :: SHEARGAMMA + ! start with collapsed structure + LOGICAL :: STARTCOLLAPSE + + LOGICAL :: DOLOCALMOVES +END MODULE KEYS diff --git a/BasicWLC/dssWLC/source/main.f90 b/BasicWLC/dssWLC/source/main.f90 new file mode 100644 index 00000000..dbc2d108 --- /dev/null +++ b/BasicWLC/dssWLC/source/main.f90 @@ -0,0 +1,264 @@ +PROGRAM MAIN + USE KEYS, ONLY : ACTION + + IMPLICIT NONE + + CALL READKEY + + SELECT CASE(ACTION) + CASE('MONTECARLO') + CALL MCDRIVER + CASE('BROWNDYN') + CALL BDDRIVER + CASE('EQUILDISTRIB') + CALL EQUILDISTDRIVER + CASE DEFAULT + PRINT*, 'UNKNOWN ACTION:', ACTION + STOP 1 + END SELECT + +CONTAINS + SUBROUTINE EQUILDISTDRIVER + ! use rejection sampling to generate chain configurations from equilibrium + ! distributions + USE CHAINUTIL, ONLY : CHAIN, SETUPCHAIN, CLEANUPCHAIN, SETCHAINPARAMS,OUTPUTSNAPSHOT + USE KEYS, ONLY : MAXNPT,OUTFILE,DUMPSNAPSHOTS,SNAPSHOTEVERY,& + & MCPRINTFREQ,MCTOTSTEPS,SNAPSHOTFILE, EQUILSAMPLETYPE, MCOUTPUTFREQ + USE SAMPLEUTIL, ONLY : GETEQUILCHAIN + + IMPLICIT NONE + + TYPE(CHAIN), TARGET :: WLCLIST(1) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: SC, SNAPCT + DOUBLE PRECISION :: DR(3), PREVCOORDS(6), NEWCOORDS(6) + + CHAINP=>WLCLIST(1); + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + ! CALL INITIALIZECHAIN(CHAINP,.FALSE.,INITRANGE) + + print*, 'chain info:', chainp%npt + + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + DO SC = 1,MCTOTSTEPS + IF (SC.GT.1.AND.EQUILSAMPLETYPE.EQ.3) THEN + PREVCOORDS = NEWCOORDS + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,NEWCOORDS,PREVCOORDS) + ELSE + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,NEWCOORDS) + ENDIF + DR = CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1) + IF (MOD(SC,MCOUTPUTFREQ).EQ.0) THEN + PRINT*, 'Chain sample:', SC, DR + ENDIF + WRITE(55,*) DR, CHAINP%UVEC(:,1) + + IF (DUMPSNAPSHOTS.AND.MOD(SC,SNAPSHOTEVERY).EQ.0) THEN + SNAPCT = SNAPCT + 1 + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,SC,SNAPCT.GT.1) + ENDIF + + ENDDO + CLOSE(55) + + END SUBROUTINE EQUILDISTDRIVER + + SUBROUTINE BDDRIVER + ! run a brownian dynamics simulation + USE BROWNDYN, ONLY : RUNBROWNDYN + USE CHAINUTIL, ONLY : CHAIN, SETUPCHAIN, SETCHAINPARAMS, CLEANUPCHAIN, INITIALIZECHAIN, INPUTSNAPSHOT, OUTPUTSNAPSHOT + USE KEYS, ONLY : NCHAIN, MAXNPT, BDSTEPS, DELTSCL, OUTFILE, & + & INITRANGE, RESTART, RESTARTFILE, RUNGEKUTTA, DOBROWN, & + & SKIPREAD, STARTEQUIL, EQUILSAMPLETYPE, EQUILBEADROD,STARTEQUILLP + USE SAMPLEUTIL, ONLY : GETEQUILCHAIN + + IMPLICIT NONE + + TYPE(CHAIN), ALLOCATABLE, TARGET :: CHAINLIST(:) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, NREAD,b + DOUBLE PRECISION :: DELT, KT + DOUBLE PRECISION :: NEWCOORDS(6), PREVCOORDS(6) + LOGICAL :: SHEARABLESAVE, STRETCHABLESAVE + DOUBLE PRECISION :: LPSAVE, gsave + + ALLOCATE(CHAINLIST(NCHAIN)) + DO C = 1,NCHAIN + CHAINP=>CHAINLIST(C) + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + ! PRINT*, 'TESTX1:', SQRT(SUM((CHAINP%POS(:,2)-CHAINP%POS(:,1))**2)) + ENDDO + + IF (RESTART) THEN + CALL INPUTSNAPSHOT(CHAINLIST,NCHAIN,RESTARTFILE,SKIPREAD,NREAD) + IF (NREAD.EQ.NCHAIN) THEN + PRINT*, 'SUCCESSFULLY READ CHAINS FROM RESTART FILE.', NCHAIN, TRIM(RESTARTFILE) + ELSE IF (NREAD.EQ.0) THEN + PRINT*, 'FAILED TO READ ANY CHAINS FROM INPUT FILE' + STOP 1 + ELSE + PRINT*, 'FAILED TO READ IN SUFFICIENT CHAINS FROM INPUT FILE. Will cycle through the read configs.', nread, nchain + DO C = NREAD+1,NCHAIN + CHAINLIST(C)%POS = CHAINLIST(MOD(C-1,NREAD)+1)%POS + CHAINLIST(C)%UVEC = CHAINLIST(MOD(C-1,NREAD)+1)%UVEC + ENDDO + ENDIF + CALL OUTPUTSNAPSHOT(CHAINP,'lastread.out',1,.FALSE.) + ELSE IF (STARTEQUIL) THEN + print*, 'Generating equilibrium configurations for all chains' + DO C = 1,NCHAIN +! print*, 'Working on chain:', C + CHAINP=>CHAINLIST(C) + IF (EQUILBEADROD) THEN + SHEARABLESAVE = CHAINP%SHEARABLE; STRETCHABLESAVE = CHAINP%STRETCHABLE + LPSAVE = CHAINP%LP(1); GSAVE = CHAINP%GAM(1) + CHAINP%SHEARABLE = .FALSE.; CHAINP%STRETCHABLE = .FALSE. + CHAINP%LP = STARTEQUILLP; CHAINP%GAM = 1D0 + ENDIF + + IF (C.GT.1.AND.EQUILSAMPLETYPE.EQ.3) THEN + PREVCOORDS = NEWCOORDS + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,NEWCOORDS,PREVCOORDS) + ELSE + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,NEWCOORDS) + ENDIF + + IF (EQUILBEADROD) THEN + CHAINP%SHEARABLE = SHEARABLESAVE; CHAINP%STRETCHABLE = STRETCHABLESAVE + CHAINP%LP = LPSAVE + CHAINP%GAM = GSAVE + ENDIF + ENDDO + ENDIF + + CHAINP=>CHAINLIST(1) + + KT = 1D0 + IF (CHAINP%SHEARABLE) THEN + DELT = DELTSCL*MIN(MINVAL(CHAINP%FRICTR(1:CHAINP%NPT)),MINVAL(CHAINP%FRICTU(1:CHAINP%NPT)))/kT + ELSE + DELT = DELTSCL*MINVAL(CHAINP%FRICTR(1:CHAINP%NPT))/kT + ENDIF + + PRINT*, 'DELT:', DELT + print*, 'FRICTR:', CHAINP%FRICTR(1:CHAINP%NPT) + PRINT*, 'FRICTU:', CHAINP%FRICTU(1:CHAINP%NPT) + + CALL RUNBROWNDYN(CHAINLIST,NCHAIN,BDSTEPS,DELT,KT,OUTFILE,RUNGEKUTTA,DOBROWN) + + DO C = 1,NCHAIN + CHAINP=>CHAINLIST(C) + CALL CLEANUPCHAIN(CHAINP) + ENDDO + DEALLOCATE(CHAINLIST) + END SUBROUTINE BDDRIVER + + SUBROUTINE MCDRIVER + USE CHAINUTIL, ONLY : CHAIN, SETUPCHAIN, SETCHAINPARAMS, & + & CLEANUPCHAIN,INITIALIZECHAIN, GETENERGY + USE MANYCHAINS, ONLY : CHAINGROUP,SETUPCHAINGROUP,SETCHAINGROUPPARAMS, & + & INITIALIZESQUARELATTICE, CLEANUPCHAINGROUP,INITIALIZEDIAMONDLATTICE,APPLYDEFORM + USE KEYS, ONLY : MAXNPT, MCTOTSTEPS, MCSTATSTEPS, MCINITSTEPS, RESTART, & + & RESTARTFILE,SQUARELATTICE,LS,GAM,NCONNECT,NCHAIN,NFORCE, SETSHEAR, & + & SHEARGAMMA, NDIAMOND, LENDIAMOND,WIDTHDIAMOND,DIAMONDLATTICE, & + & INITRANGE, STARTEQUIL,EQUILSAMPLETYPE,PARAMFROMSNAPSHOT + USE MONTECARLO, ONLY : RUNMONTECARLO, RUNMONTECARLO1CHAIN + USE INPUTUTIL, ONLY : READSNAPSHOTS + USE REDISC, ONLY : READPARAMDATA, CLEANUPDATA + USE SAMPLEUTIL, ONLY : GETEQUILCHAIN + IMPLICIT NONE + TYPE(CHAINGROUP), TARGET :: GROUP + TYPE(CHAINGROUP), POINTER :: CGRP + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: ENERGY + INTEGER :: B, STARTSTEP,C,NPT,NC,NCON, I + LOGICAL :: FILEEXISTS,SUCCESS + DOUBLE PRECISION :: DIST, SHEARMAT(3,3), NEWCOORDS(6) + + CGRP=>GROUP + + NCON = NCONNECT + IF (SQUARELATTICE) THEN + NCON = NCON + (NCHAIN/2)**2 + ELSEIF (DIAMONDLATTICE) THEN + NCON = NCON + NDIAMOND(1)*NDIAMOND(2) + (NDIAMOND(1)+1)*(NDIAMOND(2)+1) - 4 + ENDIF + + CALL SETUPCHAINGROUP(CGRP,NCHAIN,NCON,NFORCE,MAXNPT) + CALL SETCHAINGROUPPARAMS(CGRP) + + NPT = CGRP%CHAINS(1)%NPT + NC = NCHAIN/2 + + IF (SQUARELATTICE) THEN + DIST = (NPT-1)/(NC-1)*LS*gam + CALL INITIALIZESQUARELATTICE(CGRP,DIST) + ELSEIF (DIAMONDLATTICE) THEN + CALL INITIALIZEDIAMONDLATTICE(CGRP,LS*GAM,NDIAMOND,LENDIAMOND,WIDTHDIAMOND) + ELSE + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE(2)) + + IF (STARTEQUIL) THEN + IF (C.GT.1.AND.EQUILSAMPLETYPE.EQ.3) THEN + PRINT*, 'Starting equilibration pre-monte carlo using monte carlo of relative coords is not set up yet.' + STOP 1 + ELSE + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,NEWCOORDS) + ENDIF + ENDIF + ENDDO + ENDIF + + ! apply shear deformation + SHEARMAT = 0D0 + DO I = 1,3 + SHEARMAT(I,I) = 1D0 + ENDDO + IF (SETSHEAR) THEN + SHEARMAT(2,3)= SHEARGAMMA + ENDIF + CALL APPLYDEFORM(CGRP,SHEARMAT) + ! CALL SETUPCHAIN(CHAINP,MAXNPT) + ! CALL SETCHAINPARAMS(CHAINP) + ! CALL INITIALIZECHAIN(CHAINP,.FALSE.) + + ! CALL READPARAMDATA('shearWLCparams.data') + + STARTSTEP = 0 + IF (RESTART) THEN + INQUIRE(FILE=RESTARTFILE,EXIST=FILEEXISTS) + IF (FILEEXISTS) THEN + print*, 'Reading structure from file:', TRIM(ADJUSTL(RESTARTFILE)) + IF (PARAMFROMSNAPSHOT) PRINT*, 'Also extracting parameters from this file' + CALL READSNAPSHOTS(CGRP,RESTARTFILE,PARAMFROMSNAPSHOT,STARTSTEP,SUCCESS) + print*, 'Successfully read?:', SUCCESS, STARTSTEP + ELSE + PRINT*, 'WARNING: no restart file found!' + ENDIF + ENDIF + + IF (CGRP%NCHAIN.EQ.1) THEN + CHAINP=>CGRP%CHAINS(1) + + !CHAINP%FORCE = SQRT(DOT_PRODUCT(FORCE(1,:),FORCE(1,:))) + CALL RUNMONTECARLO1CHAIN(CHAINP,MCTOTSTEPS,MCSTATSTEPS,MCINITSTEPS,STARTSTEP) + + ELSE + CALL RUNMONTECARLO(CGRP,MCTOTSTEPS,MCSTATSTEPS,MCINITSTEPS,STARTSTEP) + ENDIF + + CALL CLEANUPCHAINGROUP(CGRP) + !CALL CLEANUPCHAIN(CHAINP) + !CALL CLEANUPDATA + END SUBROUTINE MCDRIVER + + +END PROGRAM MAIN diff --git a/BasicWLC/dssWLC/source/manychains.f90 b/BasicWLC/dssWLC/source/manychains.f90 new file mode 100644 index 00000000..ab391605 --- /dev/null +++ b/BasicWLC/dssWLC/source/manychains.f90 @@ -0,0 +1,710 @@ +MODULE MANYCHAINS + USE CHAINUTIL + IMPLICIT NONE + + TYPE CHAINGROUP + ! object corresponding to an interconnected group (mesh) of chains + ! number of chains in group + INTEGER :: NCHAIN=0 + ! array of chain objects + TYPE(CHAIN), POINTER :: CHAINS(:) + + ! list of interconnections between chains + ! CONNECT(n,:) = bead # 1, chain # 1, bead # 2, chain # 2 (for nth connection) + INTEGER :: NCONNECT = 0 + INTEGER, POINTER :: CONNECT(:,:) + ! strength of position connections (harmonic springs) + ! and strength of orientation connections (harmonic springs in angle) + DOUBLE PRECISION :: CONPOSMOD,CONUVECMOD + ! for each connection are the positions and/or the orientations connected? + LOGICAL :: CONNECTPOS, CONNECTUVEC + ! are connections rigidly fixed? + LOGICAL :: FIXCONNECT + ! for each bead and chain, list ONE other bead and chain it's connected to + ! -1 if not connected + INTEGER, POINTER :: CONBEAD(:,:,:) + + ! list of fixed beads + ! last index 1 = fixed position; last index 2 = fixed orientation + LOGICAL, POINTER :: FIXBEAD(:,:,:) + + ! list of forces on the group + INTEGER :: NFORCE + INTEGER, POINTER :: FORCEBEAD(:,:) ! what bead on what chain + DOUBLE PRECISION, POINTER :: FORCE(:,:) ! force vector + END TYPE CHAINGROUP + +CONTAINS + SUBROUTINE GROUPSNAPSHOT(CGRP,FILENAME,NUM,APPEND) + ! output snapshot containing all the different chains + ! NUM is an extra number given in the file (used to keep track of MC step) + ! APPEND is whether to append to file or rewrite it + + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + CHARACTER(LEN=*) :: FILENAME + INTEGER, INTENT(IN) :: NUM + LOGICAL, INTENT(IN) :: APPEND + INTEGER :: B,c + TYPE(CHAIN), POINTER :: CHAINP + + IF (APPEND) THEN + OPEN(UNIT=99,FILE=FILENAME,POSITION='APPEND') + ELSE + OPEN(UNIT=99,FILE=FILENAME,POSITION='REWIND') + ENDIF + + ! write information line + WRITE(99,'(A,1X,2I12)') 'I',CGRP%NCHAIN,NUM + + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + ! chain information line + WRITE(99,'(A,1X,I12)') 'C',CHAINP%NPT + + ! write bead lines + DO B = 1,CHAINP%NPT-1 + WRITE(99,'(A,1X,12G20.10)') 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B),& + & CHAINP%LS(B), CHAINP%LP(B), CHAINP%GAM(B), CHAINP%EPAR(B), & + & CHAINP%EPERP(B), CHAINP%EC(B) + ENDDO + B = CHAINP%NPT + WRITE(99,'(A,1X,12G20.10)') 'A', CHAINP%POS(:,B),CHAINP%UVEC(:,B), 0,0,0,0,0,0 + ENDDO + CLOSE(99) + + END SUBROUTINE GROUPSNAPSHOT + + SUBROUTINE BEADALLENERGY(CGRP,C,B,ENERGY,RECALC) + ! get all energy components involving bead B on chain C + ! if recalc is true recalculate everything; otherwise use saved BEADENERGY arrays + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: B, C + LOGICAL, INTENT(IN) :: RECALC + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: CONENERGY + INTEGER :: F, CON + + CHAINP=>CGRP%CHAINS(C) + + ENERGY = 0 + + ! Elastic energies + IF (B.LT.CHAINP%NPT) THEN + IF (RECALC) THEN + CALL GETBEADENERGY(CHAINP,B+1,CHAINP%BEADENERGY(B+1)) + ENDIF + ENERGY = ENERGY+CHAINP%BEADENERGY(B+1) + ENDIF + IF (B.GT.1) THEN + IF (RECALC) THEN + CALL GETBEADENERGY(CHAINP,B,CHAINP%BEADENERGY(B)) + ENDIF + ENERGY = ENERGY + CHAINP%BEADENERGY(B) + ENDIF + + ! connection energies + IF (.NOT.CGRP%FIXCONNECT) THEN + DO CON = 1,CGRP%NCONNECT + IF (CGRP%CONNECT(CON,1).EQ.B.AND.CGRP%CONNECT(CON,2).EQ.C & + & .OR.CGRP%CONNECT(CON,3).EQ.B.AND.CGRP%CONNECT(CON,4).EQ.C) THEN + CALL GETCONNECTENERGY(CGRP,CON,CONENERGY) + ENERGY = ENERGY + CONENERGY + ENDIF + ENDDO + ENDIF + + ! force energy + DO F = 1,CGRP%NFORCE + IF (CGRP%FORCEBEAD(F,2).EQ.C.AND.CGRP%FORCEBEAD(F,1).EQ.B) THEN + ENERGY = ENERGY - DOT_PRODUCT(CHAINP%POS(:,B),CGRP%FORCE(F,:)) + ENDIF + ENDDO + + IF (CHAINP%STERICS) THEN + PRINT*, 'ERROR IN BEADDALLENERGY: not yet set up for sterics' + stop 1 + endif + END SUBROUTINE BEADALLENERGY + + SUBROUTINE GROUPENERGY(CGRP,TOTENERGY) + ! get total energy for a group of chains + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + DOUBLE PRECISION, INTENT(OUT) :: TOTENERGY + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C,B,F,C1,C2,B1,B2,CON + DOUBLE PRECISION :: DIFF(3), DIST2,RHO, POS1(3), POS2(3), UVEC1(3), UVEC2(3),CONENERGY, FORCENERGY + + TOTENERGY = 0 + + ! internal chain energies + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + ! get bead-specific energies + DO B = 2,CHAINP%NPT + CALL GETBEADENERGY(CHAINP,B,CHAINP%BEADENERGY(B)) + ENDDO + + IF (CHAINP%STERICS) THEN + PRINT*, 'ERROR: GROUPENERGY WITH STERICS NOT YET SET UP' + STOP 1 + ENDIF + + TOTENERGY = TOTENERGY + SUM(CHAINP%BEADENERGY(1:CHAINP%NPT))-CHAINP%NPT*CHAINP%MU + ENDDO + + ! connection energies + IF (.NOT.CGRP%FIXCONNECT) THEN + DO CON = 1,CGRP%NCONNECT + CALL GETCONNECTENERGY(CGRP,CON,CONENERGY) + ! PRINT*, 'TESTX1:',CON, CGRP%CONNECT(CON,:),CONENERGY + TOTENERGY = TOTENERGY + CONENERGY + ENDDO + ENDIF + + ! force-based energies + FORCENERGY = 0D0 + DO F = 1,CGRP%NFORCE + C = CGRP%FORCEBEAD(F,2); B = CGRP%FORCEBEAD(F,1) + TOTENERGY = TOTENERGY - DOT_PRODUCT(CGRP%CHAINS(C)%POS(:,B),CGRP%FORCE(F,:)) + FORCENERGY = FORCENERGY - DOT_PRODUCT(CGRP%CHAINS(C)%POS(:,B),CGRP%FORCE(F,:)) + ENDDO + !PRINT*, 'TESTX1:', FORCENERGY + END SUBROUTINE GROUPENERGY + + SUBROUTINE GETCONNECTENERGY(CGRP,CON,energy) + ! get the connection energy for the given connection number + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: CON + DOUBLE PRECISION, INTENT(OUT) :: ENERGY + INTEGER :: C1,B1,C2,B2 + DOUBLE PRECISION :: POS1(3), POS2(3), DIFF(3), DIST2, RHO, UVEC1(3), UVEC2(3) + B1 = CGRP%CONNECT(CON,1); B2 = CGRP%CONNECT(CON,3) + C1 = CGRP%CONNECT(CON,2); C2 = CGRP%CONNECT(CON,4) + + ENERGY=0D0 + IF (CGRP%CONNECTPOS) THEN + POS1 = CGRP%CHAINS(C1)%POS(:,B1) + POS2 = CGRP%CHAINS(C2)%POS(:,B2) + DIFF = POS2-POS1 + DIST2 =DOT_PRODUCT(DIFF,DIFF) + ENERGY = ENERGY + CGRP%CONPOSMOD/2*DIST2 + ENDIF + IF (CGRP%CONNECTUVEC) THEN + UVEC1 = CGRP%CHAINS(C1)%UVEC(:,B1) + UVEC2 = CGRP%CHAINS(C2)%UVEC(:,B2) + RHO = DOT_PRODUCT(UVEC1,UVEC2) + ENERGY = ENERGY + CGRP%CONUVECMOD*(1-RHO) + ENDIF + + END SUBROUTINE GETCONNECTENERGY + + SUBROUTINE APPLYDEFORM(CGRP,SHEARMAT) + ! Apply deformation according to given matrix + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + DOUBLE PRECISION, INTENT(IN) :: SHEARMAT(3,3) + INTEGER :: C,B,I + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: TMP(3) + + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + DO B = 1,CHAINP%NPT + DO I = 1,3 + TMP(I) = DOT_PRODUCT(SHEARMAT(I,:),CHAINP%POS(:,B)) + ENDDO + CHAINP%POS(:,B) = TMP + ENDDO + ENDDO + END SUBROUTINE APPLYDEFORM + + SUBROUTINE INITIALIZESQUARELATTICE(CGRP,DIST) + ! Initialize a group of chains on a square lattice + ! with spacing DIST + ! subjected to shear deformation defined by SHEARMAT + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + DOUBLE PRECISION, INTENT(IN) :: DIST + DOUBLE PRECISION :: TMP(3) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, B, NC, I + + IF (CGRP%NCHAIN.EQ.0) THEN + PRINT*, 'ERROR: No chains to initialize.' + STOP 1 + ENDIF + + IF (MOD(CGRP%NCHAIN,2).NE.0) THEN + PRINT*, 'ERROR: cannot have square lattice with odd number of chains.', CGRP%NCHAIN + STOP 1 + ENDIF + NC = CGRP%NCHAIN/2 + + ! vertical chains + DO C = 1,NC + CHAINP=>CGRP%CHAINS(C) + CHAINP%POS(1,:) = 0D0; + CHAINP%POS(2,:) = (C-1)*DIST + CHAINP%POS(3,1) = 0D0; + DO B = 2,CHAINP%NPT + CHAINP%POS(3,B) = CHAINP%POS(3,B-1) + CHAINP%LS(B-1)*CHAINP%GAM(B-1) + ENDDO + CHAINP%UVEC = 0D0 + CHAINP%UVEC(3,:) = 1D0 + ENDDO + + ! horizontal chains + DO C = NC+1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + CHAINP%POS(1,:) = 0D0; + CHAINP%POS(3,:) = (C-NC-1)*DIST + CHAINP%POS(2,:) = 0D0; + DO B = 2,CHAINP%NPT + CHAINP%POS(2,B) = CHAINP%POS(2,B-1) + CHAINP%LS(B-1)*CHAINP%GAM(B-1) + ENDDO + CHAINP%UVEC = 0D0 + IF (CGRP%CONNECTUVEC) THEN + CHAINP%UVEC(3,:) = 1D0 + ELSE + CHAINP%UVEC(2,:) = 1D0 + ENDIF + ENDDO + + END SUBROUTINE INITIALIZESQUARELATTICE + + SUBROUTINE INITIALIZEDIAMONDLATTICE(CGRP,SEGLEN,NDIAMOND,LENDIAMOND,WIDTHDIAMOND) + ! initialize positions/orientations of beads in a diamond lattice + ! lendiamond is the length of a diamond side in number of segments + ! widthdiamond is the total width of a diamond in space + ! seglen is the width of a segment + ! NDIAMOND is the width and height of the mesh in terms of number of diamonds + USE KEYS, ONLY : STARTCOLLAPSE + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: NDIAMOND(2),LENDIAMOND + DOUBLE PRECISION :: SEGLEN,WIDTHDIAMOND + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: NL, C, B + DOUBLE PRECISION :: HEIGHT, YSTP, ZSTP, STARTY, STARTZ, STARTPT(2) + + ! number of left leaning chains + NL = NDIAMOND(1)+NDIAMOND(2)-1 + + IF (CGRP%NCHAIN.NE.2*NL) THEN + PRINT*, 'ERROR IN INITIALIZEDIAMONDLATTICE: wrong number of chains!' + STOP 1 + ENDIF + + ! height of half a diamond + HEIGHT = SQRT((SEGLEN*LENDIAMOND)**2 - (WIDTHDIAMOND/2)**2) + YSTP = WIDTHDIAMOND/2/LENDIAMOND + ZSTP = HEIGHT/LENDIAMOND + + ! place left leaning chains + DO C = 1,NL + CHAINP=>CGRP%CHAINS(C) + + IF (C.LE.NDIAMOND(1)) THEN + STARTY = WIDTHDIAMOND*C + STARTZ = 0D0 + ELSE + STARTY = WIDTHDIAMOND*NDIAMOND(1) + STARTZ = 2*HEIGHT*(C-NDIAMOND(1)) + ENDIF + STARTPT = (/STARTY,STARTZ/) + + CHAINP%POS = 0D0 + DO B = 1,CHAINP%NPT + CHAINP%POS(2:3,B) = STARTPT + (B-1)*(/-YSTP,ZSTP/) + CHAINP%UVEC(:,B) = (/0D0,0D0,1D0/) + ENDDO + IF (STARTCOLLAPSE) CHAINP%POS(2,:) = 0D0 + ENDDO + + ! place right leaning chains + DO C = NL+1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + + IF (C-NL.LE.NDIAMOND(2)) THEN + STARTY = 0 + STARTZ = 2*HEIGHT*(NDIAMOND(2)-C+NL) + ELSE + STARTY = WIDTHDIAMOND*(C-NL-NDIAMOND(2)) + STARTZ = 0 + ENDIF + STARTPT = (/STARTY,STARTZ/) + + CHAINP%POS = 0D0 + DO B = 1,CHAINP%NPT + CHAINP%POS(2:3,B) = STARTPT + (B-1)*(/YSTP,ZSTP/) + CHAINP%UVEC(:,B) = (/0D0,0D0,1D0/) + ENDDO + IF (STARTCOLLAPSE) CHAINP%POS(2,:) = 0D0 + ENDDO + + END SUBROUTINE INITIALIZEDIAMONDLATTICE + + SUBROUTINE SETUPDIAMONDLATTICE(CGRP,STARTCONNECT,NDIAMOND,LENDIAMOND,WIDTHDIAMOND,FIXBOUNDARY) + ! set up a diamond lattice of connections + ! update chain lengths appropriately + ! start with the specified connection index, to allow additional connections + ! NDIAMOND is the width and height in # of diamonds + ! LENDIAMOND is the length of a diamond side in chain segments + ! WIDTHDIAMOND is the width of each diamond in space + ! also initialize the chain + ! if FIXBOUNDARY, also fix the beads on the boundary (top/bottom and/or sides) of the lattice + + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: STARTCONNECT, NDIAMOND(2), LENDIAMOND + DOUBLE PRECISION, INTENT(IN) :: WIDTHDIAMOND + LOGICAL, INTENT(IN) :: FIXBOUNDARY(4) + INTEGER :: NL, MI, MA, CC, C, C2, B, B2, D, NINTER, CON, CURB2 + LOGICAL :: TOP1, SIDE1, TOPEND, SIDEEND + + ! number of left leaning chains + NL = NDIAMOND(1)+NDIAMOND(2)-1 + + IF (CGRP%NCHAIN.NE.2*NL) THEN + PRINT*, 'ERROR IN SETUPDIAMONDLATTICE: wrong number of chains!' + STOP 1 + ENDIF + + MI = MINVAL(NDIAMOND); MA = MAXVAL(NDIAMOND) + CON = STARTCONNECT-1 + DO CC = 1,CGRP%NCHAIN + IF (CC.LE.NL) THEN + C = CC + ELSE + C = CC - NL + ENDIF + + ! length of chain + IF (C.LT.MI) THEN + CGRP%CHAINS(CC)%NPT = 2*C*LENDIAMOND+1 + ELSE IF (C.LT.MA) THEN + CGRP%CHAINS(CC)%NPT = 2*MI*LENDIAMOND+1 + ELSE + CGRP%CHAINS(CC)%NPT = 2*(NDIAMOND(1)+NDIAMOND(2)-C)*LENDIAMOND+1 + ENDIF + ENDDO + + ! set up connections + DO C = 1,NL + IF (C.LT.MI) THEN + NINTER = 2*C + 1 ! number of intersections for this chain + ELSE IF (C.LT.MA) THEN + NINTER = 2*MI+1 + ELSE + NINTER = 2*(NDIAMOND(1)+NDIAMOND(2)-C)+1 + ENDIF + + IF (C.LE.NDIAMOND(1)) THEN + C2 = NDIAMOND(1)+2*NDIAMOND(2)+C + ELSE + C2 = 2*NDIAMOND(2)+3*NDIAMOND(1)-C + ENDIF + + ! keep track of bead on connected chain + IF (C.LE.NDIAMOND(1)) THEN + CURB2 = 1 + ELSE + curB2 = CGRP%CHAINS(C2-1)%NPT + ENDIF + + DO D = 1,NINTER + C2 = C2-1 + + B = LENDIAMOND*(D-1)+1 + B2 = CURB2 + IF (C.LE.NDIAMOND(1).AND.D.LT.C+1) THEN + CURB2 = CURB2 + LENDIAMOND + ELSE IF (C.LE.NDIAMOND(1)) then + CURB2 = CURB2 - LENDIAMOND + ELSE IF (C2.GT.NL+NDIAMOND(2)) THEN + CURB2 = CURB2 + LENDIAMOND + ELSE + CURB2 = CURB2 - LENDIAMOND + ENDIF + + IF ((D.EQ.1.AND.C.EQ.NDIAMOND(1))& + &.OR.(D.EQ.NINTER.AND.C.EQ.NDIAMOND(2))) CYCLE + CON = CON+1 + + IF (CON.GT.CGRP%NCONNECT) THEN + PRINT*, 'ERROR IN SETUPDIAMONDLATTICE: too many connections' + print*, CON, CGRP%NCONNECT, NDIAMOND + STOP 1 + ENDIF + + CGRP%CONNECT(CON,1) = B; CGRP%CONNECT(CON,2) = C + CGRP%CONNECT(CON,3) = B2; CGRP%CONNECT(CON,4) = C2 + ENDDO + + ENDDO + + ! fix beads on the boundary + IF (ANY(FIXBOUNDARY(1:2)).AND.ANY(FIXBOUNDARY(3:4))) THEN + DO CC = 1,CGRP%NCHAIN + ! start of chain is on top/bottom + TOP1 = CC.LE.NDIAMOND(1).OR.CC.GE.NL+NDIAMOND(2) + ! end of chain is on top/bottom + TOPEND = CC.GE.NDIAMOND(2).AND.CC.LE.NL+NDIAMOND(1) + ! start of chain is on sides + SIDE1 = CC.GE.NDIAMOND(1).AND.CC.LE.NL+NDIAMOND(2) + ! end of chain is on sides + SIDEEND = CC.GE.NDIAMOND(2).AND.CC.LE.NL+NDIAMOND(1) + + IF ((FIXBOUNDARY(1).AND.TOP1).OR.(FIXBOUNDARY(2).AND.SIDE1)) THEN + CGRP%FIXBEAD(1,CC,1) = FIXBOUNDARY(3) + CGRP%FIXBEAD(1,CC,2) = FIXBOUNDARY(4) + ENDIF + IF ((FIXBOUNDARY(2).AND.SIDEEND).OR.(FIXBOUNDARY(1).AND.TOPEND)) THEN + CGRP%FIXBEAD(CGRP%CHAINS(CC)%NPT,CC,1) = FIXBOUNDARY(3) + CGRP%FIXBEAD(CGRP%CHAINS(CC)%NPT,CC,2) = FIXBOUNDARY(4) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE SETUPDIAMONDLATTICE + + SUBROUTINE SETCHAINGROUPPARAMS(CGRP) + ! set parameters for a group of chains based on KEYS + ! including parameters for the chains themselves + USE KEYS, ONLY : NCONNECT, CONNECTIONS, SQUARELATTICE,FORCEBEAD,FORCE,& + & CONNECTPOS,CONNECTUVEC,CONPOSMOD,CONUVECMOD,FIXCONNECT,& + & FIXBEAD,NFIXBEAD, FIXBOUNDARY, WIDTHDIAMOND,LENDIAMOND,NDIAMOND,& + & DIAMONDLATTICE + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER :: C + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: B1,C1,B2,C2 + + CGRP%CONNECTPOS = CONNECTPOS + CGRP%CONNECTUVEC = CONNECTUVEC + CGRP%CONPOSMOD = CONPOSMOD + CGRP%CONUVECMOD = CONUVECMOD + CGRP%FIXCONNECT = FIXCONNECT + CGRP%FIXBEAD = .FALSE. + + ! initialize chain parameters + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + IF (CGRP%NCHAIN.EQ.1.AND.CGRP%NFORCE.GE.1) THEN + CALL SETCHAINPARAMS(CHAINP,SQRT(FORCE(1,1)**2 + FORCE(1,2)**2 + FORCE(1,3)**2)) + ELSE + CALL SETCHAINPARAMS(CHAINP) + ENDIF + ENDDO + + + ! explicitly specified connections + DO C = 1,NCONNECT + CGRP%CONNECT(C,:) = CONNECTIONS(C,:) + ENDDO + + IF (DIAMONDLATTICE) THEN + CALL SETUPDIAMONDLATTICE(CGRP,NCONNECT+1,NDIAMOND,LENDIAMOND,WIDTHDIAMOND,FIXBOUNDARY) + ELSEIF (SQUARELATTICE) THEN + ! set up square lattice of connections + CALL CONNECTSQUARELATTICE(CGRP,NCONNECT+1,FIXBOUNDARY) + ENDIF + + ! list of one connection for each bead + CGRP%CONBEAD = -1 + DO C = 1,CGRP%NCONNECT + C1 = CGRP%CONNECT(C,2); B1 = CGRP%CONNECT(C,1) + C2 = CGRP%CONNECT(C,4); B2 = CGRP%CONNECT(C,3) + CGRP%CONBEAD(B1,C1,:) = (/B2,C2/) + CGRP%CONBEAD(B2,C2,:) = (/B1,C1/) + ENDDO + + ! forces + DO C = 1,CGRP%NFORCE + CGRP%FORCEBEAD(C,:) = FORCEBEAD(C,:) + CGRP%FORCE(C,:) = FORCE(C,:) + ENDDO + + ! fixed beads + DO C = 1,NFIXBEAD + B1 = FIXBEAD(C,1) + C1 = FIXBEAD(C,2) + CGRP%FIXBEAD(B1,C1,1) = (FIXBEAD(C,3).GT.0) ! position + CGRP%FIXBEAD(B1,C1,2) = (FIXBEAD(C,4).GT.0) ! orientation + ENDDO + + ! PRINT*, 'TESTX FIXBEADS:', CGRP%FIXBEAD(1,1,:) + ! DO C1 = 1,CGRP%NCHAIN + ! CHAINP=>CGRP%CHAINS(C1) + ! DO B1 = 1,CHAINP%NPT + ! PRINT*, B1, C1, CGRP%FIXBEAD(B1,C1,:) + ! ENDDO + ! ENDDO + END SUBROUTINE SETCHAINGROUPPARAMS + + SUBROUTINE CONNECTSQUARELATTICE(CGRP,STARTCON,FIXBOUNDARY) + ! connect up a group of chains in a square lattice + ! must be a perfect square number of chains, + ! with lattice connections falling on beads + ! start saving connections list at given index + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: STARTCON + LOGICAL, INTENT(IN) :: FIXBOUNDARY(4) + INTEGER :: NC, NPT, C,C2,CON,DIST + TYPE(CHAIN), POINTER :: CHAINP + + IF (MOD(CGRP%NCHAIN,2).NE.0) THEN + PRINT*, 'ERROR IN SETCHAINGROUPPARAMS: cannot have square lattice with odd number of chains', CGRP%NCHAIN + STOP 1 + ENDIF + + NC = CGRP%NCHAIN/2 + + CHAINP=>CGRP%CHAINS(1) + NPT = CHAINP%NPT + DO C = 1,CGRP%NCHAIN + IF (CGRP%CHAINS(C)%NPT.NE.NPT) THEN + PRINT*, 'ERROR IN SETCHAINGROUPPARAMS: cannot have square lattice with chains of different length' + STOP 1 + ENDIF + ENDDO + + IF (MOD(NPT-1,NC-1).NE.0) THEN + PRINT*, 'ERROR IN SETCHAINGROUPPARAMS: lattice size is not integer number of beads',NPT,NC + STOP 1 + ENDIF + + DIST = (NPT-1)/(NC-1) + + CON = STARTCON-1 + DO C = 1,NC + DO C2 = 1,NC + CON = CON+1 + + IF (CON.GT.CGRP%NCONNECT) THEN + PRINT*, 'ERROR IN CONNECTSQUARELATTICE:, too many connections!', CON + STOP 1 + ENDIF + + ! first bead and chain + CGRP%CONNECT(CON,2) = C + CGRP%CONNECT(CON,1) = DIST*(C2-1)+1 + ! second bead and chain + CGRP%CONNECT(CON,4) = C2+NC + CGRP%CONNECT(CON,3) = DIST*(C-1)+1 + + IF (ANY(FIXBOUNDARY)) THEN + IF (.NOT.ALL(FIXBOUNDARY)) THEN + PRINT*, 'ERROR IN CONNECTSQUARELATTICE: not yet set up with partial fixed boundary' + STOP 1 + ENDIF + + ! fix positions for boundary intersections + IF (C.EQ.1.OR.C.EQ.NC.OR.C2.EQ.1.OR.C2.EQ.NC) THEN + CGRP%FIXBEAD(CGRP%CONNECT(CON,1),C,1) = .TRUE. + CGRP%FIXBEAD(CGRP%CONNECT(CON,3),C2+NC,1) = .TRUE. + ENDIF + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CONNECTSQUARELATTICE + + SUBROUTINE SETUPCHAINGROUP(CGRP,NCHAIN,NCON,NFORCE,MAXNPT) + ! set up a group of chains, allocating all arrays + ! do not initialize positions, parameters, or connections + ! NCON is maximal allowed number of connections + ! MAXNPT is the maximum number of beads in each chain + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER, INTENT(IN) :: NCHAIN, NCON,NFORCE,MAXNPT + INTEGER :: C + TYPE(CHAIN), POINTER :: CHAINP + + CGRP%NCHAIN = NCHAIN + CGRP%NCONNECT = NCON + CGRP%NFORCE = NFORCE + + ALLOCATE(CGRP%CHAINS(NCHAIN),CGRP%CONNECT(NCON,4),& + & CGRP%CONBEAD(MAXNPT,NCHAIN,2), & + & CGRP%FORCEBEAD(NFORCE,2),CGRP%FORCE(NFORCE,3),& + & CGRP%FIXBEAD(MAXNPT,NCHAIN,2)) + + ! allocate arrays for the chains + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + CALL SETUPCHAIN(CHAINP,MAXNPT) + ENDDO + + END SUBROUTINE SETUPCHAINGROUP + + SUBROUTINE CLEANUPCHAINGROUP(CGRP) + ! deallocate everything for a chain group, including the arrays within the chains + + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C + + DO C = 1,CGRP%NCHAIN + IF (CGRP%CHAINS(C)%ARRAYSET) THEN + CHAINP=>CGRP%CHAINS(C) + CALL CLEANUPCHAIN(CHAINP) + ENDIF + ENDDO + + DEALLOCATE(CGRP%CHAINS,CGRP%CONNECT,CGRP%FORCEBEAD, CGRP%FORCE,CGRP%CONBEAD,CGRP%FIXBEAD) + END SUBROUTINE CLEANUPCHAINGROUP + + SUBROUTINE COPYCHAINGROUP(CGRP1,CGRP2) + ! copy everything from one chain group to another + IMPLICIT NONE + TYPE(CHAINGROUP), POINTER :: CGRP1, CGRP2 + INTEGER :: C + TYPE(CHAIN), POINTER :: CHAINp1, CHAINp2 + + IF (CGRP2%NCHAIN.NE.CGRP1%NCHAIN) THEN + PRINT*,'ERROR IN COPYCHAINGROUP: cannot copy if different number of chains', CGRP1%NCHAIN, CGRP2%NCHAIN + STOP 1 + ENDIF + IF (CGRP2%NCONNECT.NE.CGRP1%NCONNECT) THEN + PRINT*, 'ERROR IN COPYCHAINGROUP: different number of connections', CGRP1%NCONNECT, CGRP2%NCONNECT + STOP 1 + ENDIF + IF (CGRP2%NFORCE.NE.CGRP1%NFORCE) THEN + PRINT*, 'ERROR IN COPYCHAINGROUP: different number of forces', CGRP1%NFORCE, CGRP2%NFORCE + STOP 1 + ENDIF + + DO C = 1,CGRP1%NCHAIN + CHAINP1=>CGRP1%CHAINS(C) + CHAINP2=>CGRP2%CHAINS(C) + + IF (CHAINP1%MAXNPT.NE.CHAINP2%MAXNPT) THEN + PRINT*, 'ERROR IN COPYCHAINGROUP: cannot copy if chains have different max size', C, CHAINP1%MAXNPT, CHAINP2%MAXNPT + STOP 1 + ENDIF + + CALL COPYCHAIN(CHAINP1,CHAINP2) + ENDDO + + CGRP2%CONNECT = CGRP1%CONNECT + CGRP2%CONPOSMOD = CGRP1%CONPOSMOD + CGRP2%CONUVECMOD = CGRP1%CONUVECMOD + CGRP2%CONNECTPOS = CGRP1%CONNECTPOS + CGRP2%CONNECTUVEC = CGRP1%CONNECTUVEC + CGRP2%FIXCONNECT = CGRP1%FIXCONNECT + CGRP2%CONBEAD = CGRP1%CONBEAD + CGRP2%FIXBEAD = CGRP1%FIXBEAD + CGRP2%FORCEBEAD = CGRP1%FORCEBEAD + CGRP2%FORCE = CGRP1%FORCE + + END SUBROUTINE COPYCHAINGROUP +END MODULE MANYCHAINS diff --git a/BasicWLC/dssWLC/source/montecarlo.f90 b/BasicWLC/dssWLC/source/montecarlo.f90 new file mode 100644 index 00000000..f092813f --- /dev/null +++ b/BasicWLC/dssWLC/source/montecarlo.f90 @@ -0,0 +1,1122 @@ +MODULE MONTECARLO + USE CHAINUTIL, ONLY : CHAIN, GETBEADENERGY,GETFORCEENERGY, GETSTERICENERGY + USE MT19937, ONLY : GRND + USE QUATUTIL, ONLY : ROTANGAX, PI + USE BROWNDYN, ONLY : GETCHAINFORCEINT + IMPLICIT NONE + +CONTAINS + SUBROUTINE RUNMONTECARLO(CGRP,TOTSTEPS,STATSTEPS,INITSTEPS,STARTSTEP) + ! run a monte carlo simulation for a group of chains + ! local bead moves only + ! all step counts are actually number of sweeps (ie: individual steps multiplied by total number of beads) + ! TOTSTEPS is total number of steps to do + ! first INITSTEPS steps do not contribute to statistics + ! Take average statistics every STATSTEPS steps thereafter + ! start with step given by STARTSTEP+1 + ! if STARTSTEP>0, append to output files rather than rewriting + + ! WARNING: currently not using BEADENERGY arrays; should implement this later for increased efficiency + USE KEYS, ONLY : TRACKDIST,MCPRINTFREQ,OUTFILE,MCOUTPUTFREQ,ADJUSTEVERY,& + & FACCTARGET,FACCTOL,ADJUSTSCL,INITRANGE,SNAPSHOTFILE,DUMPSNAPSHOTS,& + & SNAPSHOTEVERY + USE MANYCHAINS, ONLY : CHAINGROUP, GROUPSNAPSHOT, GROUPENERGY,BEADALLENERGY + USE CHAINUTIL, ONLY : CHAIN + IMPLICIT NONE + + TYPE(CHAINGROUP), POINTER :: CGRP + TYPE(CHAIN), POINTER :: CHAINP, CHAINP2 + INTEGER, INTENT(IN) :: TOTSTEPS,INITSTEPS,STATSTEPS,STARTSTEP + INTEGER :: STEP, NCT,B,C,NPT,SUBSTEP + DOUBLE PRECISION :: PREVPOS(3), PREVUVEC(3), PREVENERGY, AVGENERGY + DOUBLE PRECISION :: ARANGE, RRANGE, R2AVG, R2CUR, DELE, TMP, DR(3), FACC + INTEGER :: SNAPCT, C2, B2 + LOGICAL :: ACCEPT, ADJUSTED + DOUBLE PRECISION :: ENERGY1, ENERGY2, TESTENERGY1, TESTENERGY2 + DOUBLE PRECISION :: PREVPOS2(3), PREVUVEC2(3) + LOGICAL :: MVOTHERBEAD + DOUBLE PRECISION :: SAVEBEADENERGY(2), SAVEBEADENERGY2(2) + LOGICAL :: DOROT1, DOROT2, DOSHIFT1, DOSHIFT2 + INTEGER, ALLOCATABLE :: ALLBEADS(:,:) + INTEGER :: TOTBEADS, BEADCT + DOUBLE PRECISION :: FCT, TOTACCEPT,RU + + ! Full list of all beads to use in sampling + TOTBEADS = 0 + DO C = 1,CGRP%NCHAIN + TOTBEADS = TOTBEADS + CGRP%CHAINS(C)%NPT + ENDDO + + PRINT*, 'TOTAL NUMBER OF BEADS:', TOTBEADS + + ALLOCATE(ALLBEADS(TOTBEADS,2)) + + BEADCT = 0 + DO C = 1,CGRP%NCHAIN + DO B = 1,CGRP%CHAINS(C)%NPT + BEADCT = BEADCT + 1 + ALLBEADS(BEADCT,:) = (/B,C/) + ENDDO + ENDDO + + ! NPT = CGRP%CHAINS(1)%NPT + ! DO C = 2,CGRP%NCHAIN + ! IF (CGRP%CHAINS(C)%NPT.NE.NPT) THEN + ! PRINT*, 'ERROR IN RUNMONTECARLO: group MC not set up yet for chains of different lengths' + ! STOP 1 + ! ENDIF + ! ENDDO + + + IF (STARTSTEP.GT.0) THEN + PRINT*, 'STARTING MC FROM STEP:', STARTSTEP + ENDIF + + IF (STARTSTEP.GT.0) THEN + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN',POSITION='APPEND') + ELSE + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + ENDIF + + R2AVG = 0D0; AVGENERGY = 0D0 + NCT = 0 + TOTACCEPT = 0; + SNAPCT = 0 + FCT = 0 ! count of total steps for fraction accepted + + ARANGE = INITRANGE(1) + RRANGE = INITRANGE(2) + + ! get initial energy + CALL GROUPENERGY(CGRP,PREVENERGY) + PRINT*, 'STARTENERGY:', PREVENERGY + + ! Dump starting snapshot + IF (DUMPSNAPSHOTS) THEN + SNAPCT = SNAPCT + 1 + CALL GROUPSNAPSHOT(CGRP,SNAPSHOTFILE,STARTSTEP,STARTSTEP.GT.0) + ENDIF + + DO STEP = STARTSTEP+1,TOTSTEPS + DO SUBSTEP = 1,TOTBEADS + FCT = FCT + 1 + + ! take a Monte Carlo step + + + ! pick a bead at random + BEADCT = FLOOR(GRND()*TOTBEADS)+1 + ! find the corresponding chain and bead + C = ALLBEADS(BEADCT,2) + B = ALLBEADS(BEADCT,1) + CHAINP=>CGRP%CHAINS(C) + + PREVPOS = CHAINP%POS(:,B) + PREVUVEC = CHAINP%UVEC(:,B) + IF (B.LT.CHAINP%NPT) THEN + SAVEBEADENERGY = (/CHAINP%BEADENERGY(B),CHAINP%BEADENERGY(B+1)/) + ELSE + SAVEBEADENERGY = (/CHAINP%BEADENERGY(B),0D0/) + ENDIF + + ! move another bead along with this one + MVOTHERBEAD =CGRP%FIXCONNECT.AND.CGRP%CONBEAD(B,C,1).GT.0 + IF (MVOTHERBEAD) THEN + C2 = CGRP%CONBEAD(B,C,2); B2 = CGRP%CONBEAD(B,C,1) + CHAINP2=>CGRP%CHAINS(C2) + IF (CGRP%CONNECTPOS) PREVPOS2 = CHAINP2%POS(:,B2) + IF (CGRP%CONNECTUVEC) PREVUVEC2 = CHAINP2%UVEC(:,B2) + + IF (B2.LT.CHAINP2%NPT) THEN + SAVEBEADENERGY2 = (/CHAINP2%BEADENERGY(B2),CHAINP2%BEADENERGY(B2+1)/) + ELSE + SAVEBEADENERGY2 = (/CHAINP2%BEADENERGY(B2),0D0/) + ENDIF + ENDIF + + DOROT1 = .NOT.CGRP%FIXBEAD(B,C,2) + DOSHIFT1 = .NOT.CGRP%FIXBEAD(B,C,1) + + !CALL GROUPENERGY(CGRP,ENERGY1) + CALL BEADALLENERGY(CGRP,C,B,ENERGY1,.FALSE.) + IF (MVOTHERBEAD) THEN + ! simultaneously move 2 joined beads + CALL BEADALLENERGY(CGRP,C2,B2,TMP,.FALSE.) + ENERGY1 = ENERGY1+TMP + DOROT1 = .NOT.(CGRP%FIXBEAD(B,C,2).OR.CGRP%FIXBEAD(B2,C2,2)) + DOSHIFT1 = .NOT.(CGRP%FIXBEAD(B,C,1).OR.CGRP%FIXBEAD(B2,C2,1)) + DOROT2 = DOROT1.AND.CGRP%CONNECTUVEC + DOSHIFT2 = DOSHIFT1.AND.CGRP%CONNECTPOS + CALL LOCALMOVE2BEAD(CHAINP,CHAINP2,B,B2,ARANGE,RRANGE,& + & DOROT1,DOSHIFT1,DOROT2,DOSHIFT2) + CALL BEADALLENERGY(CGRP,C2,B2,TMP,.TRUE.) + ENERGY2 = TMP + ELSE + DOROT1 = .NOT.CGRP%FIXBEAD(B,C,2) + DOSHIFT1 = .NOT.CGRP%FIXBEAD(B,C,1) + CALL LOCALMOVE(CHAINP,ARANGE,RRANGE,B,DOROT1,DOSHIFT1) + ENERGY2 = 0 + ENDIF + CALL BEADALLENERGY(CGRP,C,B,TMP,.TRUE.) + ENERGY2 = ENERGY2+TMP + !CALL GROUPENERGY(CGRP,ENERGY2) + !PRINT*, 'TESTX0:', ENERGY1, ENERGY2, PREVENERGY + DELE = ENERGY2-ENERGY1 + + ! CALL GROUPENERGY(CGRP,TESTENERGY2) + ! IF (ABS(PREVENERGY+DELE - TESTENERGY2).GT.1D-12) THEN + ! PRINT*, 'ERROR IN ENERGY:',PREVENERGY+DELE, ENERGY2, PREVENERGY, DELE, ENERGY1 + ! print*, dele+energy1, energy2, energy1, prevenergy + ! PRINT*, C,B, CGRP%CONBEAD(B,C,:) + ! STOP 1 + ! ENDIF + + + ! decide whether to accept + IF (DELE.LT.0) THEN + ACCEPT = .TRUE. + ELSE + TMP = GRND() + ACCEPT = (TMP.LT.EXP(-DELE)) + ENDIF + + IF (ACCEPT) THEN + TOTACCEPT = TOTACCEPT + 1 + PREVENERGY = PREVENERGY + DELE + ELSE ! restore old coordinates + CHAINP%POS(:,B) = PREVPOS + CHAINP%UVEC(:,B) = PREVUVEC + IF (B.GT.1) THEN + CHAINP%BEADENERGY(B) = SAVEBEADENERGY(1) + ENDIF + IF (B.LT.CHAINP%NPT) THEN + CHAINP%BEADENERGY(B+1) = SAVEBEADENERGY(2) + ENDIF + IF (CGRP%FIXCONNECT.AND.CGRP%CONBEAD(B,C,1).GT.0) THEN + IF (CGRP%CONNECTPOS) CHAINP2%POS(:,B2) = PREVPOS2 + IF (CGRP%CONNECTUVEC) CHAINP2%UVEC(:,B2) = PREVUVEC2 + IF (B2.GT.1) THEN + CHAINP2%BEADENERGY(B2) = SAVEBEADENERGY2(1) + ENDIF + IF (B2.LT.CHAINP2%NPT) THEN + CHAINP2%BEADENERGY(B2+1) = SAVEBEADENERGY2(2) + ENDIF + ENDIF + ENDIF + + + IF (SUBSTEP.GT.1) CYCLE + ! for the first substep, check whether to do various statistics and output + + IF (STEP.GT.INITSTEPS.AND.MOD(STEP,STATSTEPS).EQ.0) THEN + ! update statistics + NCT = NCT + 1 + DR = CGRP%CHAINS(TRACKDIST(2))%POS(:,TRACKDIST(1)) & + - CGRP%CHAINS(TRACKDIST(4))%POS(:,TRACKDIST(3)) + R2CUR = DR(1)*DR(1)+DR(2)*DR(2)+DR(3)*DR(3) + R2AVG = R2AVG + R2CUR + AVGENERGY = AVGENERGY + PREVENERGY + ENDIF + + FACC = DBLE(TOTACCEPT)/FCT; + + IF (MOD(STEP,MCPRINTFREQ).EQ.0) THEN + PRINT '(A,G20.5,4G15.7,2I5,1x,L1,1x,2I4)', 'STEP, FACC, R2AVG, R2CUR:', DBLE(STEP), & + & FACC, R2AVG/NCT, AVGENERGY/NCT, PREVENERGY, C, B,accept,CGRP%CONBEAD(B,C,:) + ENDIF + IF (STEP.GT.INITSTEPS.AND.MOD(STEP,MCOUTPUTFREQ).EQ.0) THEN + DR = CGRP%CHAINS(TRACKDIST(4))%POS(:,TRACKDIST(3)) & + - CGRP%CHAINS(TRACKDIST(2))%POS(:,TRACKDIST(1)) + NPT = CGRP%CHAINS(1)%NPT + RU = DOT_PRODUCT(CGRP%CHAINS(1)%POS(:,NPT)-CGRP%CHAINS(1)%POS(:,1)& + & ,CGRP%CHAINS(1)%UVEC(:,1)) + WRITE(55,*) STEP, FACC,R2AVG/NCT, DR, PREVENERGY,RU + FLUSH(55) + ENDIF + + IF (DUMPSNAPSHOTS.AND.STEP.GT.INITSTEPS.AND.MOD(STEP,SNAPSHOTEVERY).EQ.0) THEN + SNAPCT = SNAPCT + 1 + CALL GROUPSNAPSHOT(CGRP,SNAPSHOTFILE,STEP,SNAPCT.GT.1.OR.STARTSTEP.GT.0) + ENDIF + + IF (ADJUSTEVERY.GT.0.AND.MOD(STEP,ADJUSTEVERY).EQ.0) THEN + ! adjust step range if needed + + + ADJUSTED =.FALSE. + IF (FACC.GT.FACCTARGET+FACCTOL) THEN + IF (.NOT.(ARANGE.GE.2*PI.AND..NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE)) THEN + ARANGE = ARANGE*ADJUSTSCL; RRANGE = RRANGE*ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ELSE IF (FACC.LT.FACCTARGET-FACCTOL) THEN + ARANGE = ARANGE/ADJUSTSCL; RRANGE = RRANGE/ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ARANGE = MIN(ARANGE,2*PI) + + IF (ADJUSTED) PRINT*, 'ADJUSTED RANGES:', ARANGE, RRANGE + ENDIF + + ENDDO + ENDDO + + ! verbose = .true. + CALL GROUPENERGY(CGRP,PREVENERGY) + PRINT*, 'FINAL ENERGY: ', PREVENERGY + + CLOSE(55) + + DEALLOCATE(ALLBEADS) + END SUBROUTINE RUNMONTECARLO + + SUBROUTINE RUNMONTECARLO1CHAIN(CHAINP,TOTSTEPS,STATSTEPS,INITSTEPS,STARTSTEP) + ! run a monte carlo simulation for a single chain + ! alternating the two types of crank moves + ! TOTSTEPS is total number of steps to do + ! first INITSTEPS steps do not contribute to statistics + ! Take average statistics every STATSTEPS steps thereafter + ! start with step given by STARTSTEP+1 + ! if STARTSTEP>0, append to output files rather than rewriting + ! WARNING: this will not currently work with external force + + USE KEYS, ONLY : MCPRINTFREQ,VERBOSE,OUTFILE,MCOUTPUTFREQ, ADJUSTEVERY, & + & FACCTARGET, FACCTOL, ADJUSTSCL, INITRANGE, SNAPSHOTFILE, & + & DUMPSNAPSHOTS,SNAPSHOTEVERY, DOREDISC, APPENDSNAPSHOTS, & + & USEBDENERGY, dolocalmoves, OUTPUTBEADWEIGHT, INTUWEIGHTNPT, INTRWEIGHTNPT + USE CHAINUTIL, ONLY : SETUPCHAIN,COPYCHAIN,GETENERGY,CLEANUPCHAIN,& + & GETCHAINRG,OUTPUTSNAPSHOT, GETBEADQUINT,GETBEADQRINT + !USE REDISC, ONLY : REDISCREMOVE, REDISCADD + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: TOTSTEPS,INITSTEPS,STATSTEPS,STARTSTEP + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: PREVCHAINP + INTEGER :: STEP, NCT, B + DOUBLE PRECISION :: ARANGE1, RRANGE1, ARANGE2, RRANGE2 + DOUBLE PRECISION :: DELE, PREVENERGY, TMP + LOGICAL :: ACCEPT + DOUBLE PRECISION :: DR(3), R2AVG, TESTENERGY,R2CUR, FACC1, FACC2,TANCORAVG + INTEGER :: BPIVOT(2), TOTACCEPT1, TOTACCEPT2, I + INTEGER :: MVTYPE, SNAPCT, NFLEXEDGE, NMV1, NMV2 + LOGICAL :: ADJUSTED, ENERGYFROMBD + DOUBLE PRECISION :: UU, RGAVG, RG, DELEADD, DELERM,ENERGY,RU + DOUBLE PRECISION :: RFORCE(3,CHAINP%NPT),UFORCE(3,CHAINP%NPT), ENERGY1, ENERGY2 + DOUBLE PRECISION :: D1(3),D2(3),RHO1,RHO2,D3(3),D4(3),RHO3,RHO4 + INTEGER :: NFLEXBEAD, CHOOSEB, CT + DOUBLE PRECISION :: ENERGYOLD, QINT + DOUBLE PRECISION, TARGET :: BEADWEIGHT(2,CHAINP%NPT) + DOUBLE PRECISION, POINTER :: BEADWEIGHTPT(:,:) + + BEADWEIGHTPT=>BEADWEIGHT + + ! use energy from BD calculations? + ENERGYFROMBD = USEBDENERGY.OR.(CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) + + IF (ENERGYFROMBD) THEN + PRINT*, 'Using energy calculations from brownian dynamics code' + ENDIF + + RHO1 = 0; RHO2 = 0; RHO3 = 0; RHO4 = 0; + FACC1 = FACCTARGET; FACC2 = FACCTARGET + NMV1 = 0; NMV2 = 0 + + print*, 'Starting single-chain monte carlo, with force:', CHAINP%FORCE, CHAINP%HASFORCE + + IF (STARTSTEP.GT.0) THEN + PRINT*, 'STARTING MC FROM STEP:', STARTSTEP + ENDIF + + IF (STARTSTEP.GT.0) THEN + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN',POSITION='APPEND') + ELSE + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + ENDIF + + R2AVG = 0D0; RGAVG = 0D0 + NCT = 0 + TOTACCEPT1 = 0; TOTACCEPT2 = 0 + TANCORAVG = 0D0 + SNAPCT = 0 + + ARANGE1 = INITRANGE(1) + RRANGE1 = INITRANGE(2) + ARANGE2 = INITRANGE(3) + RRANGE2 = INITRANGE(4) + + ! get initial energy + IF (ENERGYFROMBD) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,prevenergy,.FALSE.) + ELSE + CALL GETENERGY(CHAINP,PREVENERGY) + ENDIF + PRINT*, 'STARTENERGY:', PREVENERGY, chainp%npt + + ! print*, 'testx1:', chainp%beadenergy + ! do i = 1,chainp%npt + ! print*, chainp%pos(:,i),chainp%uvec(:,i) + ! enddo + ! stop 1 + + ! set up chain copy + PREVCHAINP=>WLC + + CALL SETUPCHAIN(PREVCHAINP,CHAINP%MAXNPT) + CALL COPYCHAIN(CHAINP,PREVCHAINP) + + STEP = 0 + ! Dump starting snapshot + IF (DUMPSNAPSHOTS) THEN + SNAPCT = SNAPCT + 1 + IF (OUTPUTBEADWEIGHT) THEN + ! output weight of each mobile bead by integrating over U and R vectors + BEADWEIGHT = 0D0 + DO B = 1,CHAINP%NPT + IF (.NOT.CHAINP%ISFIXED(B)) THEN + CALL GETBEADQUINT(CHAINP,B,INTUWEIGHTNPT,INTUWEIGHTNPT,QINT) + BEADWEIGHT(1,B) = QINT + CALL GETBEADQRINT(CHAINP,B,INTrWEIGHTNPT,QINT) + BEADWEIGHT(2,B) = QINT + ENDIF + ENDDO + + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,STEP,STARTSTEP.GT.0.OR.APPENDSNAPSHOTS,2,BEADWEIGHTPT) + ELSE + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,STEP,STARTSTEP.GT.0.OR.APPENDSNAPSHOTS) + + ENDIF + + ENDIF + + DO STEP = STARTSTEP+1,TOTSTEPS + ! take a Monte Carlo step + + IF (DOLOCALMOVES) THEN + ! number of moveable beads + NFLEXBEAD = CHAINP%NPT - CHAINP%NFIXBEAD + ! choose which moveable bead to move + ! WARNING: this is really inefficient... + CHOOSEB = FLOOR(GRND()*NFLEXBEAD)+1 + CT=0 + DO B = 1,CHAINP%NPT + IF (.NOT.CHAINP%ISFIXED(B)) THEN + CT = CT + 1 + ENDIF + IF (CT.EQ.CHOOSEB) THEN + BPIVOT(1) = B + EXIT + ENDIF + ENDDO + IF (B.GT.CHAINP%NPT) THEN + PRINT*, 'ERROR IN LOCALMOVE MONTECARLO: BAD B', B, CT, CHOOSEB + STOP 1 + ENDIF + + ! do the local bead move + CALL LOCALMOVE(CHAINP,ARANGE1,RRANGE1,BPIVOT(1),.TRUE.,.TRUE.) + ! get the change in energy + IF (BPIVOT(1).LT.CHAINP%NPT) THEN + ENERGYOLD = CHAINP%BEADENERGY(BPIVOT(1))+CHAINP%BEADENERGY(BPIVOT(1)+1) + CALL GETBEADENERGY(CHAINP,BPIVOT(1),CHAINP%BEADENERGY(BPIVOT(1))) + CALL GETBEADENERGY(CHAINP,BPIVOT(1)+1,CHAINP%BEADENERGY(BPIVOT(1)+1)) + DELE = CHAINP%BEADENERGY(BPIVOT(1))+CHAINP%BEADENERGY(BPIVOT(1)+1) - ENERGYOLD + ELSE + ENERGYOLD = CHAINP%BEADENERGY(BPIVOT(1)) + CALL GETBEADENERGY(CHAINP,BPIVOT(1),CHAINP%BEADENERGY(BPIVOT(1))) + DELE = CHAINP%BEADENERGY(BPIVOT(1)) - ENERGYOLD + ENDIF + + + NMV1 = NMV1 + 1 + MVTYPE = 1 + ELSE + ! decide what type of crank step to take + MVTYPE = MOD(STEP,2)+1 + IF (CHAINP%NFIXBEAD.GT.0.AND.MVTYPE.EQ.1) THEN + ! find how many flexible edge beads there are + NFLEXEDGE = 0 + IF (CHAINP%FIXBEAD(1).GT.1) & + & NFLEXEDGE = NFLEXEDGE + CHAINP%FIXBEAD(1)+1 + IF (CHAINP%FIXBEAD(CHAINP%NFIXBEAD).LT.CHAINP%NPT) & + & NFLEXEDGE = NFLEXEDGE + CHAINP%NPT-CHAINP%FIXBEAD(CHAINP%NFIXBEAD)+1 + + ! use that to get fraction of type 1 crank moves (tail pivots) + TMP = GRND() + IF (TMP.GT.DBLE(NFLEXEDGE)/CHAINP%NPT) THEN + MVTYPE = 2 + ENDIF + ENDIF + + !IF (ENERGYFROMBD) THEN + ! CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY1,.FALSE.) + !ENDIF + + IF (MVTYPE.EQ.1) THEN + CALL CRANKMOVE1(CHAINP,ARANGE1,RRANGE1,BPIVOT(1),DELE) + NMV1 = NMV1 + 1 + ELSEIF (MVTYPE.EQ.2) THEN + CALL CRANKMOVE2(CHAINP,ARANGE2,RRANGE2,BPIVOT,DELE) + NMV2 = NMV2 + 1 + ELSEIF (MVTYPE.EQ.3) THEN + PRINT*, 'MOVE 3 IS NOT SET UP FOR 1CHAIN MONTECARLO' + STOP 1 + !CALL LOCALMOVE(CHAINP,ARANGE1,RRANGE1,BPIVOT(1),DELE) + ELSE + PRINT*, 'ERROR IN MONTECARLO: UNKNOWN MOVETYPE' + STOP 1 + ENDIF + ENDIF + + IF (ENERGYFROMBD) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY2,.FALSE.) + ! DELE = ENERGY2-ENERGY1 + DELE = ENERGY2-PREVENERGY + ENDIF + + ! Rediscretize chain + ! IF (DOREDISC.AND.DELE.LT.HUGE(1D0)) THEN + ! CALL REDISCREMOVE(CHAINP,DELERM) + ! CALL REDISCADD(CHAINP,DELEADD) + ! CALL GETENERGY(CHAINP,ENERGY) + ! DELE = ENERGY-PREVENERGY + ! ENDIF + + ! decide whether to accept + IF (DELE.LT.0) THEN + ACCEPT = .TRUE. + ELSE + TMP = GRND() + ACCEPT = (TMP.LT.EXP(-DELE)) + ENDIF + + IF (ACCEPT) THEN + !D1 = CHAINP%POS(:,2)-CHAINP%POS(:,1) + !D2 = CHAINP%POS(:,CHAINP%NPT) - CHAINP%POS(:,CHAINP%NPT-1) + !UU = DOT_PRODUCT(D1,D2)/SQRT(DOT_PRODUCT(D1,D1)*DOT_PRODUCT(D2,D2)) + !print*, 'testx1:', uu, energy2 + IF (MVTYPE.EQ.2) THEN + !PREVCHAINP%BEADENERGY(BPIVOT(2)) = CHAINP%BEADENERGY(BPIVOT(2)) + TOTACCEPT2 = TOTACCEPT2+1 + ELSEIF (MVTYPE.EQ.1) THEN + TOTACCEPT1 = TOTACCEPT1 + 1 + ELSE IF (MVTYPE.EQ.3) THEN + TOTACCEPT1 = TOTACCEPT1 + 1 + !IF (BPIVOT(1).LT.chainp%NPT) THEN + ! PREVCHAINP%BEADENERGY(BPIVOT(1)+1) = CHAINP%BEADENERGY(BPIVOT(1)+1) + !ENDIF + ENDIF + + PREVENERGY = PREVENERGY + DELE + PREVCHAINP%POS = CHAINP%POS + PREVCHAINP%UVEC = CHAINP%UVEC + !PREVCHAINP%BEADENERGY(BPIVOT(1)) = CHAINP%BEADENERGY(BPIVOT(1)) + PREVCHAINP%BEADENERGY = CHAINP%BEADENERGY + PREVCHAINP%FORCEENERGY = CHAINP%FORCEENERGY + + ELSE ! restore old coordinates and energies + CHAINP%POS = PREVCHAINP%POS + CHAINP%UVEC = PREVCHAINP%UVEC + + !CHAINP%BEADENERGY(BPIVOT(1)) = PREVCHAINP%BEADENERGY(BPIVOT(1)) + CHAINP%FORCEENERGY = PREVCHAINP%FORCEENERGY + !IF (MVTYPE.EQ.2) THEN + ! CHAINP%BEADENERGY(BPIVOT(2)) = PREVCHAINP%BEADENERGY(BPIVOT(2)) + !ELSEIF (MVTYPE.EQ.3.AND.BPIVOT(1).LT.chainp%NPT) THEN + ! CHAINP%BEADENERGY(BPIVOT(1)+1) = PREVCHAINP%BEADENERGY(BPIVOT(1)+1) + ! ENDIF + CHAINP%BEADENERGY = PREVCHAINP%BEADENERGY + ENDIF + + DR = CHAINP%POS(:,chainp%NPT) - CHAINP%POS(:,1) + R2CUR = DR(1)*DR(1)+DR(2)*DR(2)+DR(3)*DR(3) + + IF (STEP.GT.INITSTEPS.AND.MOD(STEP,STATSTEPS).EQ.0) THEN + ! update statistics + NCT = NCT + 1 + R2AVG = R2AVG + R2CUR + CALL GETCHAINRG(CHAINP,RG) + RGAVG = RGAVG + RG + TANCORAVG = TANCORAVG + DOT_PRODUCT(CHAINP%UVEC(:,chainp%NPT),CHAINP%UVEC(:,1)) + ENDIF + + IF (NMV1.GT.0) THEN + FACC1 = DBLE(TOTACCEPT1)/NMV1; + ENDIF + IF (NMV2.GT.0) THEN + FACC2 = DBLE(TOTACCEPT2)/NMV2; + ENDIF + + IF (MOD(STEP,MCPRINTFREQ).EQ.0) THEN + PRINT '(A,I15,4G20.10,1x,L1,1x,2I5)', 'STEP, FACC, R2AVG, R2CUR:', STEP, & + & FACC1, FACC2, R2AVG/NCT, PREVENERGY, accept, BPIVOT + ENDIF + IF (STEP.GT.INITSTEPS.AND.MOD(STEP,MCOUTPUTFREQ).EQ.0) THEN + IF (CHAINP%SHEARABLE) THEN + UU = DOT_PRODUCT(CHAINP%UVEC(:,chainp%NPT-1),CHAINP%UVEC(:,1)) + ELSE + D1 = CHAINP%POS(:,2)-CHAINP%POS(:,1) + D2 = CHAINP%POS(:,CHAINP%NPT) - CHAINP%POS(:,CHAINP%NPT-1) + UU = DOT_PRODUCT(D1,D2)/SQRT(DOT_PRODUCT(D1,D1)*DOT_PRODUCT(D2,D2)) + RHO1 = D1(3)/SQRT(DOT_PRODUCT(D1,D1)) + RHO2= D2(3)/SQRT(DOT_PRODUCT(D2,D2)) + IF (CHAINP%NPT.GE.5) THEN + D3 = CHAINP%POS(:,3)-CHAINP%POS(:,2) + D4 = CHAINP%POS(:,4)-CHAINP%POS(:,3) + RHO3 = D3(3)/SQRT(DOT_PRODUCT(D3,D3)) + RHO4 = D4(3)/SQRT(DOT_PRODUCT(D4,D4)) + ENDIF + ENDIF + RU = DOT_PRODUCT(CHAINP%UVEC(:,1),CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1)) + CALL GETCHAINRG(CHAINP,RG) + IF (ENERGYFROMBD) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY2,.FALSE.) + ELSE + CALL GETENERGY(CHAINP,ENERGY2) + ENDIF + WRITE(55,*) STEP, FACC1, FACC2, R2AVG/NCT, DR, UU, RG, RU, & + & ENERGY2, RHO1,RHO2,RHO3,RHO4 + FLUSH(55) + ENDIF + + IF (DUMPSNAPSHOTS.AND.STEP.GT.INITSTEPS.AND.MOD(STEP,SNAPSHOTEVERY).EQ.0) THEN + SNAPCT = SNAPCT + 1 + IF (OUTPUTBEADWEIGHT) THEN + ! output weight of each mobile bead by integrating over U and R vectors + BEADWEIGHT = 0D0 + DO B = 1,CHAINP%NPT + IF (.NOT.CHAINP%ISFIXED(B)) THEN + CALL GETBEADQUINT(CHAINP,B,INTUWEIGHTNPT,INTUWEIGHTNPT,QINT) + BEADWEIGHT(1,B) = QINT + CALL GETBEADQRINT(CHAINP,B,INTRWEIGHTNPT,QINT) + BEADWEIGHT(2,B) = QINT + ENDIF + ENDDO + + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,STEP,SNAPCT.GT.1.OR.STARTSTEP.GT.0,2,BEADWEIGHTPT) + ELSE + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,STEP,SNAPCT.GT.1.OR.STARTSTEP.GT.0) + ENDIF + ENDIF + + IF (ADJUSTEVERY.GT.0.AND.MOD(STEP,ADJUSTEVERY).EQ.0) THEN + ! adjust step range if needed + + + ADJUSTED =.FALSE. + IF (FACC1.GT.FACCTARGET+FACCTOL) THEN + IF (.NOT.(ARANGE1.GE.2*PI.AND..NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE)) THEN + ARANGE1 = ARANGE1*ADJUSTSCL; RRANGE1 = RRANGE1*ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ELSE IF (FACC1.LT.FACCTARGET-FACCTOL) THEN + ARANGE1 = ARANGE1/ADJUSTSCL; RRANGE1 = RRANGE1/ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ARANGE1 = MIN(ARANGE1,2*PI) + + IF (FACC2.GT.FACCTARGET+FACCTOL) THEN + IF (.NOT.(ARANGE2.GE.2*PI.AND..NOT.CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE)) THEN + ARANGE2 = ARANGE2*ADJUSTSCL; RRANGE2 = RRANGE2*ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ELSE IF (FACC2.LT.FACCTARGET-FACCTOL) THEN + ARANGE2 = ARANGE2/ADJUSTSCL; RRANGE2 = RRANGE2/ADJUSTSCL + ADJUSTED = .TRUE. + ENDIF + ARANGE2 = MIN(ARANGE2,2*PI) + + IF (ADJUSTED) PRINT*, 'ADJUSTED RANGES:', ARANGE1, RRANGE1, ARANGE2, RRANGE2 + ENDIF + + ENDDO + + verbose = .true. + IF (ENERGYFROMBD) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,prevenergy,.FALSE.) + ELSE + CALL GETENERGY(CHAINP,PREVENERGY) + ENDIF + PRINT*, 'FINAL ENERGY: ', PREVENERGY + + CLOSE(55) + CALL CLEANUPCHAIN(PREVCHAINP) + END SUBROUTINE RUNMONTECARLO1CHAIN + + SUBROUTINE LOCALMOVE2bead(CHAINP,CHAINP2,B1,B2,ARANGE,RRANGE,DOROT1,DOSHIFT1,DOROT2,DOSHIFT2) + ! do a local move of bead B1 and the bead connected to it b2 as well + ! DOROT and DOSHIFT set whether to rotate and/or shift each bead + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP,chainp2 + DOUBLE PRECISION, INTENT(IN) :: ARANGE, RRANGE + INTEGER, INTENT(IN) :: B1,b2 + LOGICAL, INTENT(IN) :: DOROT1, DOSHIFT1,DOROT2,DOSHIFT2 + DOUBLE PRECISION :: AX(3), ANG, DELR(3), ROTMAT(3,3), TMP(3) + INTEGER :: I + + IF (DOROT1.OR.DOROT2) THEN + ! get a random axis + DO I = 1,3 + AX(I) = GRND() + ENDDO + AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + ! get a random angle + ANG = GRND()*2*ARANGE-ARANGE + ENDIF + + ! get a random shift + IF (DOSHIFT1.OR.DOSHIFT2) THEN + IF (CHAINP%STRETCHABLE) THEN + DO I = 1,3 + DELR(I) = GRND()*2*RRANGE - RRANGE + ENDDO +! ELSEIF (CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN +! PRINT*, 'STRETCHABLE AND NOT SHEARABLE NOT YET SET UP' +! STOP 2 + ELSEIF (CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + PRINT*, 'SHEARABLE AND NOT STRETCHABLE NOT YET SET UP' + STOP 2 + ELSE + DELR = 0D0 + ENDIF + ENDIF + + ! rotate selected bead + IF (DOROT1) THEN + CALL ROTANGAX(ANG,AX,CHAINP%UVEC(:,B1),TMP,.TRUE.,ROTMAT) + CHAINP%UVEC(:,B1) = TMP + ENDIF + IF (DOSHIFT1) THEN + ! shift selected bead + CHAINP%POS(:,B1) = CHAINP%POS(:,B1) + DELR + ENDIF + + ! rotate and shift other bead + IF (DOROT2) THEN + CALL ROTANGAX(ANG,AX,CHAINP2%UVEC(:,B2),TMP,(.NOT.DOROT1),ROTMAT) + CHAINP2%UVEC(:,B2) = TMP + ENDIF + IF (DOSHIFT2) CHAINP2%POS(:,B2) = CHAINP2%POS(:,B2) + DELR + END SUBROUTINE LOCALMOVE2BEAD + + SUBROUTINE LOCALMOVE(CHAINP,ARANGE,RRANGE,B,DOROT,DOSHIFT) + ! do a local move (translation + rotation) of bead B + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN) :: ARANGE, RRANGE + INTEGER, INTENT(IN) :: B + LOGICAL, INTENT(IN) :: DOROT, DOSHIFT + DOUBLE PRECISION :: AX(3), ANG, DELR(3), ROTMAT(3,3), TMP(3) + INTEGER :: I + + IF (DOROT) THEN + ! get a random axis + DO I = 1,3 + AX(I) = GRND() + ENDDO + AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + ! get a random angle + ANG = GRND()*2*ARANGE-ARANGE + ENDIF + + IF (DOSHIFT) THEN + ! get a random shift + IF (CHAINP%STRETCHABLE) THEN + DO I = 1,3 + DELR(I) = GRND()*2*RRANGE - RRANGE + ENDDO +! ELSEIF (CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN +! PRINT*, 'STRETCHABLE AND NOT SHEARABLE NOT YET SET UP' +! STOP 2 + ELSEIF (CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + PRINT*, 'SHEARABLE AND NOT STRETCHABLE NOT YET SET UP' + STOP 2 + ELSE + DELR = 0D0 + ENDIF + ENDIF + + IF (DOROT) THEN + ! rotate selected bead + CALL ROTANGAX(ANG,AX,CHAINP%UVEC(:,B),TMP,.TRUE.,ROTMAT) + CHAINP%UVEC(:,B) = TMP + ENDIF + IF (DOSHIFT) THEN + ! shift selected bead + CHAINP%POS(:,B) = CHAINP%POS(:,B) + DELR + ENDIF + END SUBROUTINE LOCALMOVE + + SUBROUTINE CRANKMOVE2(CHAINP,ARANGE,RRANGE,BPIVOT,DELE) + ! carry out a Monte Carlo move involving rotating (and shifting) chain between + ! 2 beads around axis between them + ! ARANGE is max rotation angle + ! RRANGE is range of shift + + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN) :: ARANGE, RRANGE + INTEGER, INTENT(OUT) :: BPIVOT(2) + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: I, B, TMPI + DOUBLE PRECISION :: ANG, AX(3), DELR(3), R0(3), R(3), PREVE,TMP(3) + DOUBLE PRECISION :: ROTMAT(3,3) + LOGICAL :: CALCROTMAT, CLASH + INTEGER :: STARTB, FIXB1, FIXB2, NFIXSEG, FIXSEG + + !--------- + ! get 2 random beads around which to pivot + IF (CHAINP%NFIXBEAD.GT.0) THEN + ! how many possible segments between fixed beads are there? + NFIXSEG = CHAINP%NFIXBEAD-1 + IF (CHAINP%FIXBEAD(CHAINP%NFIXBEAD).LT.CHAINP%NPT) THEN + NFIXSEG = NFIXSEG + 1 + ENDIF + IF (CHAINP%FIXBEAD(1).GT.1) THEN + NFIXSEG = NFIXSEG + 1 + ENDIF + + ! find which segment between fixed beads to work in + FIXSEG = FLOOR(GRND()*NFIXSEG)+1 + IF (CHAINP%FIXBEAD(1).GT.1) THEN + IF (FIXSEG.EQ.1) THEN + FIXB1 = 1 + ELSE + FIXB1 = CHAINP%FIXBEAD(FIXSEG-1) + ENDIF + IF (FIXSEG.GT.CHAINP%NFIXBEAD) THEN + FIXB2 = CHAINP%NPT + ELSE + FIXB2 = CHAINP%FIXBEAD(FIXSEG) + ENDIF + ELSE + FIXB1 = CHAINP%FIXBEAD(FIXSEG) + IF (FIXSEG.GE.CHAINP%NFIXBEAD) THEN + FIXB2 = CHAINP%NPT + ELSE + FIXB2 = CHAINP%FIXBEAD(FIXSEG+1) + ENDIF + ENDIF + + ! pick the actual pivot beads within the fixed segment, including edges + BPIVOT = 0 + DO WHILE (BPIVOT(1).EQ.BPIVOT(2)) + DO I = 1,2 + BPIVOT(I) = FLOOR(GRND()*(FIXB2-FIXB1+1))+FIXB1 + ENDDO + ENDDO + ELSE + BPIVOT = 0 + DO WHILE (BPIVOT(1).EQ.BPIVOT(2)) + DO I = 1,2 + BPIVOT(I) = FLOOR(GRND()*CHAINP%NPT)+1 + ENDDO + ENDDO + ENDIF + ! order the pivot beads + IF (BPIVOT(2).LT.BPIVOT(1)) THEN + TMPI = BPIVOT(1) + BPIVOT(1) = BPIVOT(2) + BPIVOT(2) = TMPI + ENDIF + + ! get axis between them + AX = CHAINP%POS(:,BPIVOT(2))-CHAINP%POS(:,BPIVOT(1)) + AX = AX/SQRT(AX(1)*AX(1)+AX(2)*AX(2)+AX(3)*AX(3)) + + ! get a random angle + ANG = GRND()*2*ARANGE-ARANGE + + ! PRINT*, 'TESTX2:', ANG, AX + ! DO I = 1,chainp%npt + ! PRINT '(A,I3,8G15.5)', 'TESTX4:', I, CHAINP%POS(:,I), CHAINP%QUATS(I)%W, & + ! & CHAINP%QUATS(I)%X, CHAINP%QUATS(I)%Y, CHAINP%QUATS(I)%Z, chainp%beadenergy(i) + ! ENDDO + ! get a random shift + IF (CHAINP%STRETCHABLE) THEN + DO I = 1,3 + DELR(I) = GRND()*2*RRANGE - RRANGE + ENDDO + ! ELSEIF (CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + ! PRINT*, 'STRETCHABLE AND NOT SHEARABLE NOT YET SET UP' + ! STOP 2 + ELSEIF (CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + PRINT*, 'SHEARABLE AND NOT STRETCHABLE NOT YET SET UP' + STOP 2 + ELSE + DELR = 0D0 + ENDIF + + ! rotate and shift everything between the pivot beads, including first but not last bead + ! do not include first bead if it is fixed + R0 = CHAINP%POS(:,BPIVOT(1)) + IF (CHAINP%ISFIXED(BPIVOT(1))) THEN + STARTB = BPIVOT(1)+1 + ELSE + STARTB = BPIVOT(1) + ENDIF + DO B = STARTB,BPIVOT(2)-1 + CALCROTMAT = B.EQ.STARTB + CALL ROTANGAX(ANG,AX,CHAINP%UVEC(:,B),TMP,CALCROTMAT,ROTMAT) + CHAINP%UVEC(:,B) = TMP + + CALL ROTANGAX(ANG,AX,CHAINP%POS(:,B)-R0,R,.FALSE.,ROTMAT) + CHAINP%POS(:,B) = R0+R+DELR + ENDDO + + ! update pivot bead energies + PREVE = CHAINP%BEADENERGY(STARTB)+ CHAINP%BEADENERGY(BPIVOT(2))+CHAINP%STERICENERGY + + CALL GETBEADENERGY(CHAINP,STARTB,CHAINP%BEADENERGY(STARTB)) + CALL GETBEADENERGY(CHAINP,BPIVOT(2),CHAINP%BEADENERGY(BPIVOT(2))) + + !IF (CHAINP%STERICS) CALL GETSTERICENERGY(CHAINP,CHAINP%STERICENERGY) + + DELE = CHAINP%BEADENERGY(STARTB) + CHAINP%BEADENERGY(BPIVOT(2))+CHAINP%STERICENERGY - PREVE + + + IF (STARTB.EQ.1) THEN + ! end to end extension also changes + PREVE = CHAINP%FORCEENERGY + CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY) + DELE = DELE+CHAINP%FORCEENERGY-PREVE + ENDIF + + IF (CHAINP%STERICS) THEN + CALL CHECKCLASHMV2(CHAINP,BPIVOT(1),BPIVOT(2),CLASH) + IF (CLASH) THEN + DELE = HUGE(1D0) + ENDIF + ENDIF + END SUBROUTINE CRANKMOVE2 + + SUBROUTINE CHECKCLASHMV2(CHAINP,B1,B2,CLASH) + ! check for a steric clash after a crank move of type 2 + ! where beads B1 through B2 (but not B2 itself) are moved + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B1, B2 + LOGICAL, INTENT(OUT) :: CLASH + !DOUBLE PRECISION, INTENT(OUT) :: STERENERGY + INTEGER :: I, J + DOUBLE PRECISION :: DIFF(3), ND2 + + ! STERENERGY = 0D0 + DO I = B1,B2-1 + DO J = 1,B1-1 ! prior stationary beads + IF (ABS(I-J).LE.CHAINP%STERSKIP) CYCLE + DIFF = CHAINP%POS(:,I)-CHAINP%POS(:,J) + ND2 = DOT_PRODUCT(DIFF,DIFF) + IF (ND2.LT.CHAINP%STERRAD2) THEN +! STERENERGY = STERENERGY + CHAINP%STERMOD*(CHAINP%STERRAD2-ND2)**2 + CLASH = .TRUE. + RETURN + ENDIF + ENDDO + + DO J = B2,CHAINP%NPT ! subsequent stationary beads + IF (ABS(I-J).LE.CHAINP%STERSKIP) CYCLE + DIFF = CHAINP%POS(:,I)-CHAINP%POS(:,J) + ND2 = DOT_PRODUCT(DIFF,DIFF) + IF (ND2.LT.CHAINP%STERRAD2) THEN + ! STERENERGY = STERENERGY + CHAINP%STERMOD*(CHAINP%STERRAD2-ND2)**2 + CLASH = .TRUE. + RETURN + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CHECKCLASHMV2 + + SUBROUTINE CRANKMOVE1(CHAINP,ARANGE,RRANGE,BPIVOT,DELE) + ! carry out a Monte Carlo move involving rotating chain from a random bead B + ! around an arbitrary axis + ! ARANGE gives maximal rotation angle + ! RRANGE gives the range for the position shift in each dimension + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN) :: ARANGE,RRANGE + INTEGER, INTENT(OUT) :: BPIVOT + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: I, B + DOUBLE PRECISION :: ANG, AX(3), DELR(3), R0(3), R(3), PREVE, TMP(3) + DOUBLE PRECISION :: ROTMAT(3,3) + LOGICAL :: CALCROTMAT, CLASH + INTEGER :: NPIV1, NPIV2, BEADUPDATE, STARTB, ENDB + + ! get a random axis + DO I = 1,3 + AX(I) = GRND() + ENDDO + AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + ! get a random angle + ANG = GRND()*2*ARANGE-ARANGE + + ! get a random shift of the chain fragment + IF (CHAINP%STRETCHABLE) THEN + DO I = 1,3 + DELR(I) = GRND()*2*RRANGE-RRANGE + ENDDO + ! ELSEIF (CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + ! PRINT*, 'STRETCHABLE AND NOT SHEARABLE NOT YET SET UP' + ! STOP 2 + ELSEIF (CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + PRINT*, 'SHEARABLE AND NOT STRETCHABLE NOT YET SET UP' + STOP 2 + ELSE + DELR = 0D0 + ENDIF + + + ! get a pivot bead at random + IF (CHAINP%NFIXBEAD.EQ.0) THEN + BPIVOT = FLOOR(GRND()*(CHAINP%NPT-1))+2 + ELSE + ! number of potential pivot beads at start of chain + IF (CHAINP%FIXBEAD(1).EQ.1) THEN + NPIV1 = 0 + ELSE + NPIV1 = CHAINP%FIXBEAD(1) + ENDIF + ! number of potential pivot beads at end of chain + IF (CHAINP%FIXBEAD(CHAINP%NFIXBEAD).EQ.CHAINP%NPT) THEN + NPIV2 = 0 + ELSE + NPIV2 = CHAINP%NPT - CHAINP%FIXBEAD(CHAINP%NFIXBEAD)+1 + ENDIF + + + B = FLOOR(GRND()*(NPIV1+NPIV2))+1 + IF (B.LE.NPIV1) THEN + BPIVOT = B + ELSE + BPIVOT = B - NPIV1+CHAINP%FIXBEAD(CHAINP%NFIXBEAD)-1 + ENDIF + ENDIF + + IF (BPIVOT.LT.1.OR.BPIVOT.GT.CHAINP%NPT) THEN + PRINT*, 'ERROR IN CRANKMOVE1: BAD BPIVOT', BPIVOT, NPIV1, NPIV2 + ENDIF + + IF (CHAINP%NFIXBEAD.GT.0.AND.BPIVOT.LE.NPIV1) THEN + STARTB = 1 + IF (CHAINP%ISFIXED(BPIVOT)) THEN + ENDB = BPIVOT - 1 + BEADUPDATE = BPIVOT + ELSE + ENDB = BPIVOT + BEADUPDATE = BPIVOT + 1 + ENDIF + IF (BEADUPDATE.GT.CHAINP%NPT) THEN + PRINT*, 'ERROR IN CRANKMV1:', BPIVOT + STOP 1 + ENDIF + ELSE + IF (CHAINP%ISFIXED(BPIVOT)) THEN + STARTB = BPIVOT+1 + BEADUPDATE = BPIVOT+1 + ELSE + STARTB = BPIVOT + BEADUPDATE = BPIVOT + ENDIF + ENDB = CHAINP%NPT + ENDIF + + IF (STARTB.LT.0.OR.ENDB.GT.CHAINP%NPT) THEN + PRINT*, 'ERROR IN CRANKMOVE1: BAD STARTB OR ENDB', STARTB, ENDB + ENDIF + + ! rotate and shift everything from bead BPIVOT to edge (including BPIVOT orientation) + R0 = CHAINP%POS(:,BPIVOT) + DO B = STARTB,ENDB + CALCROTMAT = B.EQ.STARTB + CALL ROTANGAX(ANG,AX,CHAINP%UVEC(:,B),TMP,CALCROTMAT,ROTMAT) + CHAINP%UVEC(:,B) = TMP + + CALL ROTANGAX(ANG,AX,CHAINP%POS(:,B)-R0,R,.FALSE.,ROTMAT) + CHAINP%POS(:,B) = R0+R+DELR + ENDDO + + + ! update pivot bead energy (for segment before pivot bead) + PREVE = CHAINP%BEADENERGY(BEADUPDATE) + CHAINP%FORCEENERGY+CHAINP%STERICENERGY + CALL GETBEADENERGY(CHAINP,BEADUPDATE,CHAINP%BEADENERGY(BEADUPDATE) ) + CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY) + + ! overall change in energy + DELE = CHAINP%BEADENERGY(BEADUPDATE) + CHAINP%FORCEENERGY +CHAINP%STERICENERGY- PREVE + + + + IF (CHAINP%STERICS) THEN + IF (CHAINP%NFIXBEAD.GT.0) THEN + PRINT*, 'ERROR: STERICS NOT SET UP WITH FIXBEADS' + STOP 1 + ENDIF + CALL CHECKCLASHMV1(CHAINP,BPIVOT,CLASH) + IF (CLASH) THEN + ! PRINT*, 'CLASH!' + DELE = HUGE(1D0) + ENDIF + ENDIF + + + END SUBROUTINE CRANKMOVE1 + + SUBROUTINE CHECKCLASHMV1(CHAINP,B, CLASH) + ! check for a steric clash after a crank move of type 1 + ! where beads B through end (inclusive) are moved + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B + LOGICAL, INTENT(OUT) :: CLASH + INTEGER :: I, J + DOUBLE PRECISION :: DIFF(3), ND2 + + CLASH = .FALSE. + DO I = B,CHAINP%NPT + DO J = 1,B-1 ! prior stationary beads + IF (ABS(I-J).LE.CHAINP%STERSKIP) CYCLE + DIFF = CHAINP%POS(:,I)-CHAINP%POS(:,J) + ND2 = DOT_PRODUCT(DIFF,DIFF) + IF (ND2.LT.CHAINP%STERRAD2) THEN + CLASH = .TRUE. + RETURN + ENDIF + ENDDO + ENDDO + + END SUBROUTINE CHECKCLASHMV1 + + + SUBROUTINE GETSTERMV1(CHAINP,B, STERENERGY) + ! check for a steric clash after a crank move of type 1 + ! where beads B through end (inclusive) are moved + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: B + DOUBLE PRECISION, INTENT(OUT) :: STERENERGY + INTEGER :: I, J + DOUBLE PRECISION :: DIFF(3), ND2 + + STERENERGY = 0D0 + DO I = B,CHAINP%NPT + DO J = 1,B-1 ! prior stationary beads + IF (ABS(I-J).LE.CHAINP%STERSKIP) CYCLE + DIFF = CHAINP%POS(:,I)-CHAINP%POS(:,J) + ND2 = DOT_PRODUCT(DIFF,DIFF) + IF (ND2.LT.CHAINP%STERRAD2) THEN + STERENERGY = STERENERGY + CHAINP%STERMOD*(ND2-CHAINP%STERRAD2)**2 + ENDIF + ENDDO + ENDDO + + END SUBROUTINE GETSTERMV1 + +END MODULE MONTECARLO diff --git a/BasicWLC/dssWLC/source/mt19937.f90 b/BasicWLC/dssWLC/source/mt19937.f90 new file mode 100644 index 00000000..24bf6e12 --- /dev/null +++ b/BasicWLC/dssWLC/source/mt19937.f90 @@ -0,0 +1,298 @@ +! A Fortran-program for MT19937: Real number version + +! Code converted using TO_F90 by Alan Miller +! Date: 1999-11-26 Time: 17:09:23 +! Latest revision - 5 February 2002 +! A new seed initialization routine has been added based upon the new +! C version dated 26 January 2002. +! This version assumes that integer overflows do NOT cause crashes. +! This version is compatible with Lahey's ELF90 compiler, +! and should be compatible with most full Fortran 90 or 95 compilers. +! Notice the strange way in which umask is specified for ELF90. + +! genrand() generates one pseudorandom real number (double) which is +! uniformly distributed on [0,1]-interval, for each call. +! sgenrand(seed) set initial values to the working area of 624 words. +! Before genrand(), sgenrand(seed) must be called once. (seed is any 32-bit +! integer except for 0). +! Integer generator is obtained by modifying two lines. +! Coded by Takuji Nishimura, considering the suggestions by +! Topher Cooper and Marc Rieffel in July-Aug. 1997. + +! This library is free software; you can redistribute it and/or modify it +! under the terms of the GNU Library General Public License as published by +! the Free Software Foundation; either version 2 of the License, or (at your +! option) any later version. This library is distributed in the hope that +! it will be useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU Library General Public License for more details. +! You should have received a copy of the GNU Library General Public License +! along with this library; if not, write to the Free Foundation, Inc., +! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +! Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. +! When you use this, send an email to: matumoto@math.keio.ac.jp +! with an appropriate reference to your work. + +!*********************************************************************** +! Fortran translation by Hiroshi Takano. Jan. 13, 1999. + +! genrand() -> double precision function grnd() +! sgenrand(seed) -> subroutine sgrnd(seed) +! integer seed + +! This program uses the following standard intrinsics. +! ishft(i,n): If n > 0, shifts bits in i by n positions to left. +! If n < 0, shifts bits in i by n positions to right. +! iand (i,j): Performs logical AND on corresponding bits of i and j. +! ior (i,j): Performs inclusive OR on corresponding bits of i and j. +! ieor (i,j): Performs exclusive OR on corresponding bits of i and j. + +!*********************************************************************** + +MODULE mt19937 +IMPLICIT NONE +INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) + +! Period parameters +INTEGER, PARAMETER :: n = 624, n1 = n+1, m = 397, mata = -1727483681 +! constant vector a +INTEGER, PARAMETER :: umask = -2147483647 - 1 +! most significant w-r bits +INTEGER, PARAMETER :: lmask = 2147483647 +! least significant r bits +! Tempering parameters +INTEGER, PARAMETER :: tmaskb= -1658038656, tmaskc= -272236544 + +! the array for the state vector +INTEGER, SAVE :: mt(0:n-1), mti = n1 +! mti==N+1 means mt[N] is not initialized +LOGICAL, SAVE :: RNORMRESTART = .FALSE. +REAL, SAVE :: RNORMVSAVE, RNORMSLNSAVE + +PRIVATE +PUBLIC :: dp, sgrnd, grnd, init_genrand, rnorm, MT,mti,MVNORM +! efk: global variables to allow restarting of rnorm() calculation from savefile +PUBLIC :: RNORMRESTART, RNORMSLNSAVE, RNORMVSAVE + +CONTAINS + + +SUBROUTINE sgrnd(seed) +! This is the original version of the seeding routine. +! It was replaced in the Japanese version in C on 26 January 2002 +! It is recommended that routine init_genrand is used instead. + +INTEGER, INTENT(IN) :: seed + +! setting initial seeds to mt[N] using the generator Line 25 of Table 1 in +! [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp102] + +mt(0)= IAND(seed, -1) +DO mti=1,n-1 + mt(mti) = IAND(69069 * mt(mti-1), -1) +END DO + +RETURN +END SUBROUTINE sgrnd +!*********************************************************************** + +SUBROUTINE init_genrand(seed) +! This initialization is based upon the multiplier given on p.106 of the +! 3rd edition of Knuth, The Art of Computer Programming Vol. 2. + +! This version assumes that integer overflow does NOT cause a crash. + +INTEGER, INTENT(IN) :: seed + +INTEGER :: latest + +mt(0) = seed +latest = seed +DO mti = 1, n-1 + latest = IEOR( latest, ISHFT( latest, -30 ) ) + latest = latest * 1812433253 + mti + mt(mti) = latest +END DO + +RETURN +END SUBROUTINE init_genrand +!*********************************************************************** + +FUNCTION grndORIG() RESULT(fn_val) +REAL (dp) :: fn_val + +INTEGER, SAVE :: mag01(0:1) = (/ 0, mata /) +! mag01(x) = x * MATA for x=0,1 +INTEGER :: kk, y + +! These statement functions have been replaced with separate functions +! tshftu(y) = ISHFT(y,-11) +! tshfts(y) = ISHFT(y,7) +! tshftt(y) = ISHFT(y,15) +! tshftl(y) = ISHFT(y,-18) + +IF(mti >= n) THEN +! generate N words at one time + IF(mti == n+1) THEN +! if sgrnd() has not been called, + CALL sgrnd(4357) +! a default initial seed is used + END IF + + DO kk = 0, n-m-1 + y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) + mt(kk) = IEOR(IEOR(mt(kk+m), ISHFT(y,-1)),mag01(IAND(y,1))) + END DO + DO kk = n-m, n-2 + y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) + mt(kk) = IEOR(IEOR(mt(kk+(m-n)), ISHFT(y,-1)),mag01(IAND(y,1))) + END DO + y = IOR(IAND(mt(n-1),umask), IAND(mt(0),lmask)) + mt(n-1) = IEOR(IEOR(mt(m-1), ISHFT(y,-1)),mag01(IAND(y,1))) + mti = 0 +END IF + +y = mt(mti) +mti = mti + 1 +y = IEOR(y, tshftu(y)) +y = IEOR(y, IAND(tshfts(y),tmaskb)) +y = IEOR(y, IAND(tshftt(y),tmaskc)) +y = IEOR(y, tshftl(y)) + +IF(y < 0) THEN + fn_val = (DBLE(y) + 2.0D0**32) / (2.0D0**32 - 1.0D0) +ELSE + fn_val = DBLE(y) / (2.0D0**32 - 1.0D0) +END IF + +RETURN +END FUNCTION grndORIG + + +FUNCTION tshftu(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,-11) +RETURN +END FUNCTION tshftu + + +FUNCTION tshfts(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,7) +RETURN +END FUNCTION tshfts + + +FUNCTION tshftt(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,15) +RETURN +END FUNCTION tshftt + + +FUNCTION tshftl(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,-18) +RETURN +END FUNCTION tshftl + +! EFK: 2009/08/01 converted to use MT19937 random number generator +FUNCTION rnorm() RESULT( fn_val ) + +! Generate a random normal deviate using the polar method. +! Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating +! normal variables', Siam Rev., vol.6, 260-264, 1964. + +IMPLICIT NONE +REAL :: fn_val + +! Local variables + +REAL :: u, sum +REAL, SAVE :: v, sln +LOGICAL, SAVE :: second = .FALSE. +REAL, PARAMETER :: one = 1.0, vsmall = TINY( one ) + +!print*, 'testx0:', second, rnormrestart, v, sln, rnormvsave, rnormslnsave + +IF (second) THEN +! If second, use the second random number generated on last call + + second = .false. + fn_val = v*sln + +ELSE IF (RNORMRESTART) THEN + ! efk: restart from global variables in save file + SECOND = .FALSE. + v = rnormvsave; sln = rnormslnsave + FN_Val = v*sln + RNORMRESTART = .FALSE. +ELSE +! First call; generate a pair of random normals + + second = .true. + DO + U = GRND( ) + V = GRND() + u = SCALE( u, 1 ) - one + v = SCALE( v, 1 ) - one + sum = u*u + v*v + vsmall ! vsmall added to prevent LOG(zero) / zero + IF(sum < one) EXIT + END DO + sln = SQRT(- SCALE( LOG(sum), 1 ) / sum) + fn_val = u*sln +END IF + +RNORMVSAVE = V; RNORMSLNSAVE = SLN; RNORMRESTART = SECOND + +RETURN +END FUNCTION rnorm + +! EFK: 2009/09/03 wrap around GRND so that it does not ever give exactly 0 or 1 +FUNCTION grnd() RESULT(fn_val) + REAL (dp) :: fn_val + + FN_VAL = 0D0 + DO WHILE (FN_VAL.EQ.0D0.OR.FN_VAL.EQ.1D0) + FN_VAL = GRNDORIG() + ENDDO +END FUNCTION grnd + +! --------------------------- +! EFK: multivariate normal deviates +! --------------------------- +FUNCTION MVNORM(N,MU,CHOLCOV) RESULT (XDEV) + ! Get a multivariate normal random deviate + ! N is the dimension + ! MU(N) is the vector of means + ! lower triangle of CHOLCOV contains the cholesky decomposition of the + ! covariance matrix, obtained previously with DPOTRF from LAPACK + IMPLICIT NONE + INTEGER, INTENT(IN) :: N + DOUBLE PRECISION, INTENT(IN) :: MU(N), CHOLCOV(N,N) + DOUBLE PRECISION :: XDEV(N) + INTEGER :: I + + ! Get standard normal random deviates + DO I = 1,N + XDEV(I) = RNORM() + ENDDO + + ! convert to multivariate normal + CALL DTRMV('L','N','N',N,CHOLCOV,N,XDEV,1) + XDEV = XDEV + MU +END FUNCTION MVNORM + +END MODULE mt19937 + + + diff --git a/BasicWLC/dssWLC/source/nrtype.f90 b/BasicWLC/dssWLC/source/nrtype.f90 new file mode 100644 index 00000000..f58d4039 --- /dev/null +++ b/BasicWLC/dssWLC/source/nrtype.f90 @@ -0,0 +1,30 @@ +MODULE nrtype + INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) + INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) + INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) + INTEGER, PARAMETER :: SP = KIND(1.0) + INTEGER, PARAMETER :: DP = KIND(1.0D0) + INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) + INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) + INTEGER, PARAMETER :: LGT = KIND(.true.) + REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp + REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp + REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp + REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp + REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp + REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp + REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp + REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + TYPE sprs2_sp + INTEGER(I4B) :: n,len + REAL(SP), DIMENSION(:), POINTER :: val + INTEGER(I4B), DIMENSION(:), POINTER :: irow + INTEGER(I4B), DIMENSION(:), POINTER :: jcol + END TYPE sprs2_sp + TYPE sprs2_dp + INTEGER(I4B) :: n,len + REAL(DP), DIMENSION(:), POINTER :: val + INTEGER(I4B), DIMENSION(:), POINTER :: irow + INTEGER(I4B), DIMENSION(:), POINTER :: jcol + END TYPE sprs2_dp +END MODULE nrtype diff --git a/BasicWLC/dssWLC/source/nrutils.f90 b/BasicWLC/dssWLC/source/nrutils.f90 new file mode 100644 index 00000000..d846106f --- /dev/null +++ b/BasicWLC/dssWLC/source/nrutils.f90 @@ -0,0 +1,1154 @@ +MODULE nrutil + USE nrtype + IMPLICIT NONE + INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8 + INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 + INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 + INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 + INTEGER(I4B), PARAMETER :: NPAR_POLY=8 + INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 + INTERFACE array_copy + MODULE PROCEDURE array_copy_r, array_copy_d, array_copy_i + END INTERFACE + INTERFACE swap + MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & + swap_cv,swap_cm,swap_z,swap_zv,swap_zm, & + masked_swap_rs,masked_swap_rv,masked_swap_rm + END INTERFACE + INTERFACE reallocate + MODULE PROCEDURE reallocate_rv,reallocate_rm,& + reallocate_iv,reallocate_im,reallocate_hv + END INTERFACE + INTERFACE imaxloc + MODULE PROCEDURE imaxloc_r,imaxloc_i + END INTERFACE + INTERFACE assert + MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v + END INTERFACE + INTERFACE assert_eq + MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn + END INTERFACE + INTERFACE arth + MODULE PROCEDURE arth_r, arth_d, arth_i + END INTERFACE + INTERFACE geop + MODULE PROCEDURE geop_r, geop_d, geop_i, geop_c, geop_dv + END INTERFACE + INTERFACE cumsum + MODULE PROCEDURE cumsum_r,cumsum_i + END INTERFACE + INTERFACE poly + MODULE PROCEDURE poly_rr,poly_rrv,poly_dd,poly_ddv,& + poly_rc,poly_cc,poly_msk_rrv,poly_msk_ddv + END INTERFACE + INTERFACE poly_term + MODULE PROCEDURE poly_term_rr,poly_term_cc + END INTERFACE + INTERFACE outerprod + MODULE PROCEDURE outerprod_r,outerprod_d + END INTERFACE + INTERFACE outerdiff + MODULE PROCEDURE outerdiff_r,outerdiff_d,outerdiff_i + END INTERFACE + INTERFACE scatter_add + MODULE PROCEDURE scatter_add_r,scatter_add_d + END INTERFACE + INTERFACE scatter_max + MODULE PROCEDURE scatter_max_r,scatter_max_d + END INTERFACE + INTERFACE diagadd + MODULE PROCEDURE diagadd_rv,diagadd_r + END INTERFACE + INTERFACE diagmult + MODULE PROCEDURE diagmult_rv,diagmult_r + END INTERFACE + INTERFACE get_diag + MODULE PROCEDURE get_diag_rv, get_diag_dv + END INTERFACE + INTERFACE put_diag + MODULE PROCEDURE put_diag_rv, put_diag_r + END INTERFACE +CONTAINS +!BL + SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) + REAL(SP), DIMENSION(:), INTENT(IN) :: src + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied + n_copied=min(size(src),size(dest)) + n_not_copied=size(src)-n_copied + dest(1:n_copied)=src(1:n_copied) + END SUBROUTINE array_copy_r +!BL + SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied) + REAL(DP), DIMENSION(:), INTENT(IN) :: src + REAL(DP), DIMENSION(:), INTENT(OUT) :: dest + INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied + n_copied=min(size(src),size(dest)) + n_not_copied=size(src)-n_copied + dest(1:n_copied)=src(1:n_copied) + END SUBROUTINE array_copy_d +!BL + SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest + INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied + n_copied=min(size(src),size(dest)) + n_not_copied=size(src)-n_copied + dest(1:n_copied)=src(1:n_copied) + END SUBROUTINE array_copy_i +!BL +!BL + SUBROUTINE swap_i(a,b) + INTEGER(I4B), INTENT(INOUT) :: a,b + INTEGER(I4B) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_i +!BL + SUBROUTINE swap_r(a,b) + REAL(SP), INTENT(INOUT) :: a,b + REAL(SP) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_r +!BL + SUBROUTINE swap_rv(a,b) + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b + REAL(SP), DIMENSION(SIZE(a)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_rv +!BL + SUBROUTINE swap_c(a,b) + COMPLEX(SPC), INTENT(INOUT) :: a,b + COMPLEX(SPC) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_c +!BL + SUBROUTINE swap_cv(a,b) + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b + COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_cv +!BL + SUBROUTINE swap_cm(a,b) + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b + COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_cm +!BL + SUBROUTINE swap_z(a,b) + COMPLEX(DPC), INTENT(INOUT) :: a,b + COMPLEX(DPC) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_z +!BL + SUBROUTINE swap_zv(a,b) + COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: a,b + COMPLEX(DPC), DIMENSION(SIZE(a)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_zv +!BL + SUBROUTINE swap_zm(a,b) + COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: a,b + COMPLEX(DPC), DIMENSION(size(a,1),size(a,2)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_zm +!BL + SUBROUTINE masked_swap_rs(a,b,mask) + REAL(SP), INTENT(INOUT) :: a,b + LOGICAL(LGT), INTENT(IN) :: mask + REAL(SP) :: swp + if (mask) then + swp=a + a=b + b=swp + end if + END SUBROUTINE masked_swap_rs +!BL + SUBROUTINE masked_swap_rv(a,b,mask) + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(a)) :: swp + where (mask) + swp=a + a=b + b=swp + end where + END SUBROUTINE masked_swap_rv +!BL + SUBROUTINE masked_swap_rm(a,b,mask) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b + LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp + where (mask) + swp=a + a=b + b=swp + end where + END SUBROUTINE masked_swap_rm +!BL +!BL + FUNCTION reallocate_rv(p,n) + REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_rv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_rv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_rv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_rv +!BL + FUNCTION reallocate_iv(p,n) + INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_iv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_iv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_iv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_iv +!BL + FUNCTION reallocate_hv(p,n) + CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_hv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_hv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_hv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_hv +!BL + FUNCTION reallocate_rm(p,n,m) + REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm + INTEGER(I4B), INTENT(IN) :: n,m + INTEGER(I4B) :: nold,mold,ierr + allocate(reallocate_rm(n,m),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_rm: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p,1) + mold=size(p,2) + reallocate_rm(1:min(nold,n),1:min(mold,m))=& + p(1:min(nold,n),1:min(mold,m)) + deallocate(p) + END FUNCTION reallocate_rm +!BL + FUNCTION reallocate_im(p,n,m) + INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im + INTEGER(I4B), INTENT(IN) :: n,m + INTEGER(I4B) :: nold,mold,ierr + allocate(reallocate_im(n,m),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_im: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p,1) + mold=size(p,2) + reallocate_im(1:min(nold,n),1:min(mold,m))=& + p(1:min(nold,n),1:min(mold,m)) + deallocate(p) + END FUNCTION reallocate_im +!BL + FUNCTION ifirstloc(mask) + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + INTEGER(I4B) :: ifirstloc + INTEGER(I4B), DIMENSION(1) :: loc + loc=maxloc(merge(1,0,mask)) + ifirstloc=loc(1) + if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1 + END FUNCTION ifirstloc +!BL + FUNCTION imaxloc_r(arr) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B) :: imaxloc_r + INTEGER(I4B), DIMENSION(1) :: imax + imax=maxloc(arr(:)) + imaxloc_r=imax(1) + END FUNCTION imaxloc_r +!BL + FUNCTION imaxloc_i(iarr) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr + INTEGER(I4B), DIMENSION(1) :: imax + INTEGER(I4B) :: imaxloc_i + imax=maxloc(iarr(:)) + imaxloc_i=imax(1) + END FUNCTION imaxloc_i +!BL + FUNCTION iminloc(arr) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), DIMENSION(1) :: imin + INTEGER(I4B) :: iminloc + imin=minloc(arr(:)) + iminloc=imin(1) + END FUNCTION iminloc +!BL + SUBROUTINE assert1(n1,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1 + if (.not. n1) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert1' + end if + END SUBROUTINE assert1 +!BL + SUBROUTINE assert2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2 + if (.not. (n1 .and. n2)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert2' + end if + END SUBROUTINE assert2 +!BL + SUBROUTINE assert3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3 + if (.not. (n1 .and. n2 .and. n3)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert3' + end if + END SUBROUTINE assert3 +!BL + SUBROUTINE assert4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3,n4 + if (.not. (n1 .and. n2 .and. n3 .and. n4)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert4' + end if + END SUBROUTINE assert4 +!BL + SUBROUTINE assert_v(n,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, DIMENSION(:), INTENT(IN) :: n + if (.not. all(n)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert_v' + end if + END SUBROUTINE assert_v +!BL + FUNCTION assert_eq2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2 + INTEGER :: assert_eq2 + if (n1 == n2) then + assert_eq2=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq2' + end if + END FUNCTION assert_eq2 +!BL + FUNCTION assert_eq3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3 + INTEGER :: assert_eq3 + if (n1 == n2 .and. n2 == n3) then + assert_eq3=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq3' + end if + END FUNCTION assert_eq3 +!BL + FUNCTION assert_eq4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4 + INTEGER :: assert_eq4 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then + assert_eq4=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq4' + end if + END FUNCTION assert_eq4 +!BL + FUNCTION assert_eqn(nn,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, DIMENSION(:), INTENT(IN) :: nn + INTEGER :: assert_eqn + if (all(nn(2:) == nn(1))) then + assert_eqn=nn(1) + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eqn' + end if + END FUNCTION assert_eqn +!BL + SUBROUTINE nrerror(string) + CHARACTER(LEN=*), INTENT(IN) :: string + write (*,*) 'nrerror: ',string + STOP 'program terminated by nrerror' + END SUBROUTINE nrerror +!BL + FUNCTION arth_r(first,increment,n) + REAL(SP), INTENT(IN) :: first,increment + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: arth_r + INTEGER(I4B) :: k,k2 + REAL(SP) :: temp + if (n > 0) arth_r(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_r(k)=arth_r(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_r(k)=arth_r(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_r +!BL + FUNCTION arth_d(first,increment,n) + REAL(DP), INTENT(IN) :: first,increment + INTEGER(I4B), INTENT(IN) :: n + REAL(DP), DIMENSION(n) :: arth_d + INTEGER(I4B) :: k,k2 + REAL(DP) :: temp + if (n > 0) arth_d(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_d(k)=arth_d(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_d(k)=arth_d(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_d +!BL + FUNCTION arth_i(first,increment,n) + INTEGER(I4B), INTENT(IN) :: first,increment,n + INTEGER(I4B), DIMENSION(n) :: arth_i + INTEGER(I4B) :: k,k2,temp + if (n > 0) arth_i(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_i(k)=arth_i(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_i(k)=arth_i(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_i +!BL +!BL + FUNCTION geop_r(first,factor,n) + REAL(SP), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: geop_r + INTEGER(I4B) :: k,k2 + REAL(SP) :: temp + if (n > 0) geop_r(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_r(k)=geop_r(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_r(k)=geop_r(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_r +!BL + FUNCTION geop_d(first,factor,n) + REAL(DP), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + REAL(DP), DIMENSION(n) :: geop_d + INTEGER(I4B) :: k,k2 + REAL(DP) :: temp + if (n > 0) geop_d(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_d(k)=geop_d(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_d(k)=geop_d(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_d +!BL + FUNCTION geop_i(first,factor,n) + INTEGER(I4B), INTENT(IN) :: first,factor,n + INTEGER(I4B), DIMENSION(n) :: geop_i + INTEGER(I4B) :: k,k2,temp + if (n > 0) geop_i(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_i(k)=geop_i(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_i(k)=geop_i(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_i +!BL + FUNCTION geop_c(first,factor,n) + COMPLEX(SP), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + COMPLEX(SP), DIMENSION(n) :: geop_c + INTEGER(I4B) :: k,k2 + COMPLEX(SP) :: temp + if (n > 0) geop_c(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_c(k)=geop_c(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_c(k)=geop_c(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_c +!BL + FUNCTION geop_dv(first,factor,n) + REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + REAL(DP), DIMENSION(size(first),n) :: geop_dv + INTEGER(I4B) :: k,k2 + REAL(DP), DIMENSION(size(first)) :: temp + if (n > 0) geop_dv(:,1)=first(:) + if (n <= NPAR_GEOP) then + do k=2,n + geop_dv(:,k)=geop_dv(:,k-1)*factor(:) + end do + else + do k=2,NPAR2_GEOP + geop_dv(:,k)=geop_dv(:,k-1)*factor(:) + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*& + spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_dv +!BL +!BL + RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP), OPTIONAL, INTENT(IN) :: seed + REAL(SP), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j + REAL(SP) :: sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=0.0_sp + if (present(seed)) sd=seed + ans(1)=arr(1)+sd + if (n < NPAR_CUMSUM) then + do j=2,n + ans(j)=ans(j-1)+arr(j) + end do + else + ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) + end if + END FUNCTION cumsum_r +!BL + RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + INTEGER(I4B), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j,sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=0_i4b + if (present(seed)) sd=seed + ans(1)=arr(1)+sd + if (n < NPAR_CUMSUM) then + do j=2,n + ans(j)=ans(j-1)+arr(j) + end do + else + ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) + end if + END FUNCTION cumsum_i +!BL +!BL + RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP), OPTIONAL, INTENT(IN) :: seed + REAL(SP), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j + REAL(SP) :: sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=1.0_sp + if (present(seed)) sd=seed + ans(1)=arr(1)*sd + if (n < NPAR_CUMPROD) then + do j=2,n + ans(j)=ans(j-1)*arr(j) + end do + else + ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2) + end if + END FUNCTION cumprod +!BL +!BL + FUNCTION poly_rr(x,coeffs) + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs + REAL(SP) :: poly_rr + REAL(SP) :: pow + REAL(SP), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_rr=0.0_sp + else if (n < NPAR_POLY) then + poly_rr=coeffs(n) + do i=n-1,1,-1 + poly_rr=x*poly_rr+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_rr=vec(1) + deallocate(vec) + end if + END FUNCTION poly_rr +!BL + FUNCTION poly_dd(x,coeffs) + REAL(DP), INTENT(IN) :: x + REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs + REAL(DP) :: poly_dd + REAL(DP) :: pow + REAL(DP), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_dd=0.0_dp + else if (n < NPAR_POLY) then + poly_dd=coeffs(n) + do i=n-1,1,-1 + poly_dd=x*poly_dd+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_dp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_dd=vec(1) + deallocate(vec) + end if + END FUNCTION poly_dd +!BL + FUNCTION poly_rc(x,coeffs) + COMPLEX(SPC), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs + COMPLEX(SPC) :: poly_rc + COMPLEX(SPC) :: pow + COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_rc=0.0_sp + else if (n < NPAR_POLY) then + poly_rc=coeffs(n) + do i=n-1,1,-1 + poly_rc=x*poly_rc+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_rc=vec(1) + deallocate(vec) + end if + END FUNCTION poly_rc +!BL + FUNCTION poly_cc(x,coeffs) + COMPLEX(SPC), INTENT(IN) :: x + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs + COMPLEX(SPC) :: poly_cc + COMPLEX(SPC) :: pow + COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_cc=0.0_sp + else if (n < NPAR_POLY) then + poly_cc=coeffs(n) + do i=n-1,1,-1 + poly_cc=x*poly_cc+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_cc=vec(1) + deallocate(vec) + end if + END FUNCTION poly_cc +!BL + FUNCTION poly_rrv(x,coeffs) + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x + REAL(SP), DIMENSION(size(x)) :: poly_rrv + INTEGER(I4B) :: i,n,m + m=size(coeffs) + n=size(x) + if (m <= 0) then + poly_rrv=0.0_sp + else if (m < n .or. m < NPAR_POLY) then + poly_rrv=coeffs(m) + do i=m-1,1,-1 + poly_rrv=x*poly_rrv+coeffs(i) + end do + else + do i=1,n + poly_rrv(i)=poly_rr(x(i),coeffs) + end do + end if + END FUNCTION poly_rrv +!BL + FUNCTION poly_ddv(x,coeffs) + REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x + REAL(DP), DIMENSION(size(x)) :: poly_ddv + INTEGER(I4B) :: i,n,m + m=size(coeffs) + n=size(x) + if (m <= 0) then + poly_ddv=0.0_dp + else if (m < n .or. m < NPAR_POLY) then + poly_ddv=coeffs(m) + do i=m-1,1,-1 + poly_ddv=x*poly_ddv+coeffs(i) + end do + else + do i=1,n + poly_ddv(i)=poly_dd(x(i),coeffs) + end do + end if + END FUNCTION poly_ddv +!BL + FUNCTION poly_msk_rrv(x,coeffs,mask) + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv + poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp) + END FUNCTION poly_msk_rrv +!BL + FUNCTION poly_msk_ddv(x,coeffs,mask) + REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv + poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp) + END FUNCTION poly_msk_ddv +!BL +!BL + RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) + REAL(SP), DIMENSION(:), INTENT(IN) :: a + REAL(SP), INTENT(IN) :: b + REAL(SP), DIMENSION(size(a)) :: u + INTEGER(I4B) :: n,j + n=size(a) + if (n <= 0) RETURN + u(1)=a(1) + if (n < NPAR_POLYTERM) then + do j=2,n + u(j)=a(j)+b*u(j-1) + end do + else + u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b) + u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) + end if + END FUNCTION poly_term_rr +!BL + RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a + COMPLEX(SPC), INTENT(IN) :: b + COMPLEX(SPC), DIMENSION(size(a)) :: u + INTEGER(I4B) :: n,j + n=size(a) + if (n <= 0) RETURN + u(1)=a(1) + if (n < NPAR_POLYTERM) then + do j=2,n + u(j)=a(j)+b*u(j-1) + end do + else + u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b) + u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) + end if + END FUNCTION poly_term_cc +!BL +!BL + FUNCTION zroots_unity(n,nn) + INTEGER(I4B), INTENT(IN) :: n,nn + COMPLEX(SPC), DIMENSION(nn) :: zroots_unity + INTEGER(I4B) :: k + REAL(SP) :: theta + zroots_unity(1)=1.0 + theta=TWOPI/n + k=1 + do + if (k >= nn) exit + zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC) + zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*& + zroots_unity(2:min(k,nn-k)) + k=2*k + end do + END FUNCTION zroots_unity +!BL + FUNCTION outerprod_r(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r + outerprod_r = spread(a,dim=2,ncopies=size(b)) * & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerprod_r +!BL + FUNCTION outerprod_d(a,b) + REAL(DP), DIMENSION(:), INTENT(IN) :: a,b + REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d + outerprod_d = spread(a,dim=2,ncopies=size(b)) * & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerprod_d +!BL + FUNCTION outerdiv(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv + outerdiv = spread(a,dim=2,ncopies=size(b)) / & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiv +!BL + FUNCTION outersum(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outersum + outersum = spread(a,dim=2,ncopies=size(b)) + & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outersum +!BL + FUNCTION outerdiff_r(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r + outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_r +!BL + FUNCTION outerdiff_d(a,b) + REAL(DP), DIMENSION(:), INTENT(IN) :: a,b + REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d + outerdiff_d = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_d +!BL + FUNCTION outerdiff_i(a,b) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b + INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i + outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_i +!BL + FUNCTION outerand(a,b) + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b + LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand + outerand = spread(a,dim=2,ncopies=size(b)) .and. & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerand +!BL + SUBROUTINE scatter_add_r(dest,source,dest_index) + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + REAL(SP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_add_r') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) + end do + END SUBROUTINE scatter_add_r + SUBROUTINE scatter_add_d(dest,source,dest_index) + REAL(DP), DIMENSION(:), INTENT(OUT) :: dest + REAL(DP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_add_d') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) + end do + END SUBROUTINE scatter_add_d + SUBROUTINE scatter_max_r(dest,source,dest_index) + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + REAL(SP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_max_r') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) + end do + END SUBROUTINE scatter_max_r + SUBROUTINE scatter_max_d(dest,source,dest_index) + REAL(DP), DIMENSION(:), INTENT(OUT) :: dest + REAL(DP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_max_d') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) + end do + END SUBROUTINE scatter_max_d +!BL + SUBROUTINE diagadd_rv(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), DIMENSION(:), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') + do j=1,n + mat(j,j)=mat(j,j)+diag(j) + end do + END SUBROUTINE diagadd_rv +!BL + SUBROUTINE diagadd_r(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=mat(j,j)+diag + end do + END SUBROUTINE diagadd_r +!BL + SUBROUTINE diagmult_rv(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), DIMENSION(:), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') + do j=1,n + mat(j,j)=mat(j,j)*diag(j) + end do + END SUBROUTINE diagmult_rv +!BL + SUBROUTINE diagmult_r(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=mat(j,j)*diag + end do + END SUBROUTINE diagmult_r +!BL + FUNCTION get_diag_rv(mat) + REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat + REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv + INTEGER(I4B) :: j + j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') + do j=1,size(mat,1) + get_diag_rv(j)=mat(j,j) + end do + END FUNCTION get_diag_rv +!BL + FUNCTION get_diag_dv(mat) + REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat + REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv + INTEGER(I4B) :: j + j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv') + do j=1,size(mat,1) + get_diag_dv(j)=mat(j,j) + end do + END FUNCTION get_diag_dv +!BL + SUBROUTINE put_diag_rv(diagv,mat) + REAL(SP), DIMENSION(:), INTENT(IN) :: diagv + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + INTEGER(I4B) :: j,n + n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') + do j=1,n + mat(j,j)=diagv(j) + end do + END SUBROUTINE put_diag_rv +!BL + SUBROUTINE put_diag_r(scal,mat) + REAL(SP), INTENT(IN) :: scal + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=scal + end do + END SUBROUTINE put_diag_r +!BL + SUBROUTINE unit_matrix(mat) + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat + INTEGER(I4B) :: i,n + n=min(size(mat,1),size(mat,2)) + mat(:,:)=0.0_sp + do i=1,n + mat(i,i)=1.0_sp + end do + END SUBROUTINE unit_matrix +!BL + FUNCTION upper_triangle(j,k,extra) + INTEGER(I4B), INTENT(IN) :: j,k + INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra + LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle + INTEGER(I4B) :: n + n=0 + if (present(extra)) n=extra + upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n) + END FUNCTION upper_triangle +!BL + FUNCTION lower_triangle(j,k,extra) + INTEGER(I4B), INTENT(IN) :: j,k + INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra + LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle + INTEGER(I4B) :: n + n=0 + if (present(extra)) n=extra + lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n) + END FUNCTION lower_triangle +!BL + FUNCTION vabs(v) + REAL(SP), DIMENSION(:), INTENT(IN) :: v + REAL(SP) :: vabs + vabs=sqrt(dot_product(v,v)) + END FUNCTION vabs +!BL +END MODULE nrutil diff --git a/BasicWLC/dssWLC/source/quartic.f b/BasicWLC/dssWLC/source/quartic.f new file mode 100644 index 00000000..f562e06d --- /dev/null +++ b/BasicWLC/dssWLC/source/quartic.f @@ -0,0 +1,182 @@ +C ***QUARTIC************************************************25.03.98 +C Solution of a quartic equation +C ref.: J. E. Hacke, Amer. Math. Monthly, Vol. 48, 327-328, (1941) +C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING +C Downloaded from: http://van-der-waals.pc.uni-koeln.de/quartic/quartic.f +C ****************************************************************** +C dd(0:4) (i) vector containing the polynomial coefficients +C sol(1:4) (o) results, real part +C soli(1:4) (o) results, imaginary part +C Nsol (o) number of real solutions +C ================================================================== + subroutine quartic(dd,sol,soli,Nsol) + implicit double precision (a-h,o-z) + dimension dd(0:4),sol(4),soli(4) + dimension AA(0:3),z(3) +C + Nsol = 0 + a = dd(4) + b = dd(3) + c = dd(2) + d = dd(1) + e = dd(0) +C + if (dd(4).eq.0.d+0) then + write(6,*)'ERROR: NOT A QUARTIC EQUATION' + return + endif +C + p = (-3.d+0*b**2 + 8.d+0*a*c)/(8.d+0*a**2) + q = (b**3 - 4.d+0*a*b*c + 8.d+0*d*a**2)/(8.d+0*a**3) + r = (-3.d+0*b**4 + 16.d+0*a*b**2*c - 64.d+0*a**2*b*d + + & 256.d+0*a**3*e)/(256.d+0*a**4) +C +C solve cubic resolvent + AA(3) = 8.d+0 + AA(2) = -4.d+0*p + AA(1) = -8.d+0*r + AA(0) = 4.d+0*p*r - q**2 + call cubic(AA,z,ncube) +C + zsol = -1.d+99 + do 5 i=1,ncube + 5 zsol = max(zsol,z(i)) + z(1) = zsol + xK2 = 2.d+0 * z(1) - p + xK = sqrt(xK2) +C----------------------------------------------- + if (xK.eq.0.d+0) then + xL2 = z(1)**2 - r + if (xL2.lt.0.d+0) then + write(6,*)'Sorry, no solution' + return + endif + xL = sqrt(xL2) + else + xL = q/(2.d+0 * xK) + endif +C----------------------------------------------- + sqp = xK2 - 4.d+0*(z(1) + xL) + sqm = xK2 - 4.d+0*(z(1) - xL) +C + do 10 i=1,4 + 10 soli(i) = 0.d+0 + if (sqp.ge.0.d+0 .and. sqm.ge.0.d+0) then + sol(1) = 0.5d+0*( xK + sqrt(sqp)) + sol(2) = 0.5d+0*( xK - sqrt(sqp)) + sol(3) = 0.5d+0*(-xK + sqrt(sqm)) + sol(4) = 0.5d+0*(-xK - sqrt(sqm)) + Nsol = 4 + else if (sqp.ge.0.d+0 .and. sqm.lt.0.d+0) then + sol(1) = 0.5d+0*(xK + sqrt(sqp)) + sol(2) = 0.5d+0*(xK - sqrt(sqp)) + sol(3) = -0.5d+0*xK + sol(4) = -0.5d+0*xK + soli(3) = sqrt(-0.25d+0 * sqm) + soli(4) = -sqrt(-0.25d+0 * sqm) + Nsol = 2 + else if (sqp.lt.0.d+0 .and. sqm.ge.0.d+0) then + sol(1) = 0.5d+0*(-xK + sqrt(sqm)) + sol(2) = 0.5d+0*(-xK - sqrt(sqm)) + sol(3) = 0.5d+0*xK + sol(4) = 0.5d+0*xK + soli(3) = sqrt(-0.25d+0 * sqp) + soli(4) = -sqrt(-0.25d+0 * sqp) + Nsol = 2 + else if (sqp.lt.0.d+0 .and. sqm.lt.0.d+0) then + sol(1) = -0.5d+0*xK + sol(2) = -0.5d+0*xK + soli(1) = sqrt(-0.25d+0 * sqm) + soli(2) = -sqrt(-0.25d+0 * sqm) + sol(3) = 0.5d+0*xK + sol(4) = 0.5d+0*xK + soli(3) = sqrt(-0.25d+0 * sqp) + soli(4) = -sqrt(-0.25d+0 * sqp) + Nsol = 0 + endif + do 20 i=1,4 + 20 sol(i) = sol(i) - b/(4.d+0*a) +C + return + END + +C ***CUBIC************************************************08.11.1986 +C Solution of a cubic equation +C Equations of lesser degree are solved by the appropriate formulas. +C The solutions are arranged in ascending order. +C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING +C ****************************************************************** +C A(0:3) (i) vector containing the polynomial coefficients +C X(1:L) (o) results +C L (o) number of valid solutions (beginning with X(1)) +C ================================================================== + SUBROUTINE CUBIC(A,X,L) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION A(0:3),X(3),U(3) + PARAMETER(PI=3.1415926535897932D+0,THIRD=1.D+0/3.D+0) + INTRINSIC MIN,MAX,ACOS +C +C define cubic root as statement function + CBRT(Z)=SIGN(ABS(Z)**THIRD,Z) +C +C ==== determine the degree of the polynomial ==== +C + IF (A(3).NE.0.D+0) THEN +C +C cubic problem + W=A(2)/A(3)*THIRD + P=(A(1)/A(3)*THIRD-W**2)**3 + Q=-.5D+0*(2.D+0*W**3-(A(1)*W-A(0))/A(3)) + DIS=Q**2+P + IF (DIS.LT.0.D+0) THEN +C three real solutions! +C Confine the argument of ACOS to the interval [-1;1]! + PHI=ACOS(MIN(1.D+0,MAX(-1.D+0,Q/SQRT(-P)))) + P=2.D+0*(-P)**(5.D-1*THIRD) + DO 100 I=1,3 + 100 U(I)=P*COS((PHI+DBLE(2*I)*PI)*THIRD)-W + X(1)=MIN(U(1),U(2),U(3)) + X(2)=MAX(MIN(U(1),U(2)),MIN(U(1),U(3)),MIN(U(2),U(3))) + X(3)=MAX(U(1),U(2),U(3)) + L=3 + ELSE +C only one real solution! + DIS=SQRT(DIS) + X(1)=CBRT(Q+DIS)+CBRT(Q-DIS)-W + L=1 + END IF +C + ELSE IF (A(2).NE.0.D+0) THEN +C +C quadratic problem + P=5.D-1*A(1)/A(2) + DIS=P**2-A(0)/A(2) + IF (DIS.GE.0.D+0) THEN +C two real solutions! + X(1)=-P-SQRT(DIS) + X(2)=-P+SQRT(DIS) + L=2 + ELSE +C no real solution! + L=0 + END IF +C + ELSE IF (A(1).NE.0.D+0) THEN +C +C linear equation + X(1)=-A(0)/A(1) + L=1 +C + ELSE +C no equation + L=0 + END IF +C +C ==== perform one step of a newton iteration in order to minimize +C round-off errors ==== + DO 110 I=1,L + X(I)=X(I)-(A(0)+X(I)*(A(1)+X(I)*(A(2)+X(I)*A(3)))) + * /(A(1)+X(I)*(2.D+0*A(2)+X(I)*3.D+0*A(3))) + 110 CONTINUE + RETURN + END diff --git a/BasicWLC/dssWLC/source/quatutil.f90 b/BasicWLC/dssWLC/source/quatutil.f90 new file mode 100644 index 00000000..c974d4ca --- /dev/null +++ b/BasicWLC/dssWLC/source/quatutil.f90 @@ -0,0 +1,832 @@ +MODULE QUATUTIL + ! utilities for dealing with quaternions + ! and other representations of rotation + ! including euler angles, rotation matrices, and alpha+gamma and z-axis-vector representations + + IMPLICIT NONE + LOGICAL :: TESTQUAT = .FALSE. + DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 + ! when z1^2+z2^2 goes below tiny when working with alpha+gamma & zvec coordinates + ! use the v->0 approximation + DOUBLE PRECISION, PARAMETER :: NZTINY=1D-14 + + ! definition of a quaternion class + TYPE QUATERNION + DOUBLE PRECISION :: W, X, Y, Z + END TYPE QUATERNION + + INTERFACE OPERATOR (*) + MODULE PROCEDURE QPRODUCT + END INTERFACE + + INTERFACE OPERATOR (/) + MODULE PROCEDURE QDIVIDE + END INTERFACE + +CONTAINS + SUBROUTINE QUAT2SCREW(QUAT,TRANS,HELCRD) + ! convert from a rotation+translation to screw coordinates + ! (equivalently to overall helix coordinates) + ! returns height, angle, radius, orientation of + ! canonical system relative to helix system (3 euler angles) + TYPE(QUATERNION), INTENT(IN) :: QUAT + DOUBLE PRECISION, INTENT(IN) :: TRANS(3) + DOUBLE PRECISION, INTENT(OUT) :: HELCRD(6) + DOUBLE PRECISION :: THETA, AX(3), TP(3), ST2, CT2, AXT3, A, B, G, NP, NTP + + ! angle-axis representation from quaternion + THETA = 2*ACOS(QUAT%W) + + IF (THETA.EQ.0D0) THEN ! translation only + HELCRD(1) = SQRT(DOT_PRODUCT(TRANS,TRANS)) + HELCRD(2) = 0D0 + HELCRD(3) = 0D0 + HELCRD(4:6) = (/0D0,0D0,0D0/) + RETURN + ENDIF + + ! angle of rotation around screw axis + HELCRD(2) = THETA + + AX = (/QUAT%X,QUAT%Y,QUAT%Z/); + ST2 = SIN(THETA/2) + AX = AX/ST2; ! normalize the axis + + ! shift along screw axis + HELCRD(1) = DOT_PRODUCT(TRANS,AX) + + ! translation in plane perpendicular to axis + TP = TRANS - HELCRD(1)*AX + NTP = SQRT(DOT_PRODUCT(TP,TP)) + + ! radius of screw + NP = NTP/(2*ST2) + HELCRD(3) = NP + + ! cross-product of AX x TP + AXT3 = AX(1)*TP(2) - AX(2)*TP(1) + + ! euler angles of screw axis coord system relative to canonical + A = atan2(AX(1),-AX(2)) + B = ACOS(AX(3)) + CT2 = QUAT%W/ST2 + G = ATAN2(-TP(3)-CT2*AXT3,-AXT3+CT2*TP(3)) + + ! euler angles of canonical system relative to screw axis + HELCRD(4:6) = (/PI-G,B,PI-A/) + END SUBROUTINE QUAT2SCREW + + SUBROUTINE COORDS2QUAT(AG,ZVEC,Q) + ! convert from an alpha+gamma angle and a vector along the z axis + ! to a normalized quaternion + ! note: this doesn't work if beta = pi + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: AG, ZVEC(3) + TYPE(QUATERNION) :: Q + DOUBLE PRECISION :: NZ, ZAX(3), ALPHA,BETA,GAMMA + + NZ = SQRT(DOT_PRODUCT(ZVEC,ZVEC)) + ZAX = ZVEC/NZ + + NZ = ZAX(1)**2+ZAX(2)**2 + + IF (NZ.EQ.0) THEN + CALL EULER2QUAT((/AG,0D0,0D0/),Q) + ELSE + ALPHA = ATAN2(ZAX(1),-ZAX(2)); GAMMA = AG-ALPHA + BETA = ACOS(ZAX(3)) + CALL EULER2QUAT((/ALPHA,BETA,GAMMA/),Q) + ENDIF + + END SUBROUTINE COORDS2QUAT + + SUBROUTINE COORDS2ROTMAT(AG,ZVEC,MAT,DMATAG,DMATZ) + ! convert from coordinates that include the alpha+gamma euler angle + ! and a non-normalized vector along the Z axis in canonical reference system + ! to a rotation matrix + ! if DMATAG and DMATZ are provided, also get derivatives of all the matrix + ! components wrt the coordinates + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: AG, ZVEC(3) + DOUBLE PRECISION, INTENT(OUT) :: MAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMATAG(3,3), DMATZ(3,3,3) + DOUBLE PRECISION :: NZTOT2, NZTOT, NZ, Z1, Z2, Z3 + DOUBLE PRECISION :: Z11,Z22,Z12,Z13,Z23,CAG,SAG + DOUBLE PRECISION :: DXDZ(3,3),DYDZ(3,3) + + IF ((PRESENT(DMATAG).AND..NOT.PRESENT(DMATZ)).OR.& + & (.NOT.PRESENT(DMATAG).AND.PRESENT(DMATZ))) THEN + PRINT*, 'ERROR IN COORDS2ROTMAT: neither or both of DMATAG and DMATZ must be provided' + stop 1 + ENDIF + + MAT = 0D0 + + ! normalize the zaxis + NZTOT2 = DOT_PRODUCT(ZVEC,ZVEC); NZTOT = SQRT(NZTOT2) + MAT(:,3) = ZVEC/NZTOT + Z1 = MAT(1,3); Z2 = MAT(2,3); + Z11 = Z1*Z1; Z22 = Z2*Z2; + NZ = Z11+Z22; + Z3 = MAT(3,3) + Z12 = Z1*Z2; Z23 = Z2*Z3; Z13 = Z1*Z3 + + ! IF (Z3.LT.-1D0+SQRT(NZTINY)) THEN + ! PRINT*, 'ERROR IN COORDS2ROTMAT: have hit gimbal lock with Z axis pointing downward. Not set up to deal with this yet.' + ! STOP 1 + ! ENDIF + + CAG = COS(AG); SAG = SIN(AG) + + !IF (TESTQUAT) PRINT*, 'TESTX1', NZ, NZTINY + IF (NZ.LT.NZTINY) THEN + IF (ZVEC(3).LT.0) THEN + PRINT*, 'PROBLEM IN COORDS2ROTMAT: some z-vector falls along the & + & negative z axis. This causes gimbal lock. & + & If working with a single nucleosome you may be able to & + & avoid this by rotating the entire structure slightly, or & + & by using RANDSTART to start the linker beads in different positions.' + stop 1 + endif + MAT(1,1) = CAG - (Z12*SAG+Z11*CAG)/2 + !if (testquat) print*, 'testx2:', mat(1,1) + MAT(2,1) = SAG - (Z22*SAG+Z12*CAG)/2 + + MAT(1,2) = -SAG+(Z11*SAG-Z12*CAG)/2 + MAT(2,2) = CAG-(Z22*CAG-Z12*SAG)/2 + ELSE + MAT(1,1) = (Z22*CAG-Z12*SAG+Z3*(Z12*SAG+Z11*CAG))/NZ + MAT(2,1) = (-Z12*CAG + Z11*SAG+Z3*(Z22*SAG+Z12*CAG))/NZ + + MAT(1,2) = -(Z22*SAG+Z12*CAG+Z3*(-Z12*CAG+Z11*SAG))/NZ + !if (testquat) print*, 'testx2:', mat(1,2) + MAT(2,2) = (Z12*SAG+Z11*CAG+Z3*(Z22*CAG-Z12*SAG))/NZ + ENDIF + MAT(3,1) = -Z2*SAG-Z1*CAG + MAT(3,2) = -CAG*Z2+SAG*Z1 + + IF (PRESENT(DMATZ)) THEN + DMATZ = 0D0 + + ! derivative of normalized z axis wrt ZVEC coordinates (transposed) + DMATZ(:,3,1) = -ZVEC(1)*MAT(:,3)/NZTOT2 + (/1D0/NZTOT,0D0,0D0/) + DMATZ(:,3,2) = -ZVEC(2)*MAT(:,3)/NZTOT2 + (/0D0,1D0/NZTOT,0D0/) + DMATZ(:,3,3) = -ZVEC(3)*MAT(:,3)/NZTOT2 + (/0D0,0D0,1D0/NZTOT/) + + IF (NZ.LT.NZTINY) THEN + + DXDZ(1,1) = -Z2*SAG/2-Z1*CAG + DXDZ(1,2) = -Z1*SAG/2 + DXDZ(2,1) = -Z2*CAG/2 + DXDZ(2,2) = -Z2*SAG-Z1*CAG/2 + DXDZ(:,3) = 0D0 + + DYDZ(1,1) = Z1*SAG - Z2*CAG/2 + DYDZ(1,2) = -Z1*CAG/2 + DYDZ(2,1) = Z2*SAG/2 + DYDZ(2,2) = -Z2*CAG+Z1*SAG/2 + DYDZ(:,3) = 0D0 + ELSE + ! derivative wrt normalized z axis + DXDZ(1,1) = (-Z2*SAG+Z23*SAG+2*Z13*CAG-2*Z1*MAT(1,1))/NZ + DXDZ(1,2) = (2*Z2*CAG-Z1*SAG+Z13*SAG-2*Z2*MAT(1,1))/NZ + DXDZ(1,3) = (Z12*SAG+Z11*CAG)/NZ + + DXDZ(2,1) = (-Z2*CAG+2*Z1*SAG+Z23*CAG - 2*MAT(2,1)*Z1)/NZ + DXDZ(2,2) = (-Z1*CAG+2*Z23*SAG + Z13*CAG-2*MAT(2,1)*Z2)/NZ + DXDZ(2,3) = (Z22*SAG+Z12*CAG)/NZ + + DYDZ(1,1) = (-Z2*CAG+Z23*CAG-2*Z13*SAG-2*Z1*MAT(1,2))/NZ + DYDZ(1,2) = (-2*Z2*SAG-Z1*CAG+Z13*CAG-2*Z2*MAT(1,2))/NZ + DYDZ(1,3) = (Z12*CAG-Z11*SAG)/NZ + + DYDZ(2,1) = (Z2*SAG+2*Z1*CAG-Z23*SAG-2*Z1*MAT(2,2))/NZ + DYDZ(2,2) = (Z1*SAG+2*Z23*CAG-Z13*SAG-2*Z2*MAT(2,2))/NZ + DYDZ(2,3) = (Z22*CAG-Z12*SAG)/NZ + ENDIF + DXDZ(3,:) = (/-CAG,-SAG,0D0/) + DYDZ(3,:) = (/SAG,-CAG,0D0/) + + ! derivatives of new axes + + CALL DGEMM('N','N',3,3,3,1D0,DXDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,1,:),3) + CALL DGEMM('N','N',3,3,3,1D0,DYDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,2,:),3) + + + !CALL DGEMV('N',3,3,1D0,DZ,3,DMATZTMP(2,1,:),1,0D0,DMATZ(2,1,:),1) + !DMATZ(2,1,:) = DXDZ + ENDIF + + IF (PRESENT(DMATAG)) THEN + DMATAG = 0D0 + + IF (NZ.LT.NZTINY) THEN + DMATAG(1,1) = -SAG-(Z12*CAG-Z11*SAG)/2 + DMATAG(2,1) = CAG-(Z22*CAG-Z12*SAG)/2 + + DMATAG(1,2) = -CAG+(Z11*CAG+Z12*SAG)/2 + DMATAG(2,2) = -SAG+(Z22*SAG+Z12*CAG)/2 + ELSE + DMATAG(1,1) = (-Z22*SAG-Z1*Z2*CAG+Z1*Z23*CAG-Z3*Z11*SAG)/NZ + DMATAG(2,1) = (Z12*SAG+Z11*CAG + Z3*Z22*CAG-Z1*Z23*SAG)/NZ + + DMATAG(1,2) = (-Z22*CAG+Z12*SAG-Z1*Z23*SAG-Z3*Z11*CAG)/NZ + DMATAG(2,2) = (Z12*CAG-Z11*SAG-Z22*Z3*SAG-Z1*Z23*CAG)/NZ + ENDIF + DMATAG(3,1) = -Z2*CAG+Z1*SAG ! dX3/dA + DMATAG(3,2) = SAG*Z2+CAG*Z1! dY3/dA + ENDIF + END SUBROUTINE COORDS2ROTMAT + + ! ----------------- STUFF INVOLVING TREATING QUATERNIONS AS 4-VECTORS ----- + FUNCTION QUAT2QV(Q) + ! convert a quaternion object to a 4-vector + IMPLICIT NONE + DOUBLE PRECISION :: QUAT2QV(4) + TYPE(QUATERNION), INTENT(IN) :: Q + + QUAT2QV = (/Q%W,Q%X,Q%Y,Q%Z/) + END FUNCTION QUAT2QV + + SUBROUTINE ROTQV(THETA,AX,QV,DT) + ! get the quaternion corresponding to rotation around axis AX by angle THETA + ! as a 4-vector (in QV); optionally, also get the derivative wrt theta + ! WARNING: AX assumed to be normalized; does not check for this! + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: THETA, AX(3) + DOUBLE PRECISION, INTENT(OUT) :: QV(4) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DT(4) + DOUBLE PRECISION :: CT, ST + + CT = COS(THETA/2); ST = SIN(THETA/2); + QV(1) = CT + QV(2:4) = ST*AX + + IF (PRESENT(DT)) THEN + DT(1) = -ST/2 + DT(2:4) = CT/2*AX + ENDIF + + END SUBROUTINE ROTQV + + SUBROUTINE QVPTMULT(Q,PT,QP,DQ,DPT) + ! multiply a quaternion by a point in 3-space + ! returns the result in QP + ! optionally, returns derivatives wrt the quaternion components in dQ + ! or wrt point components in DPT + ! WARNING: no normalization happens here + ! WARNING: this is a pretty inefficient way to do things; should fix at some point without resorting to rotation matrices + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: Q(4),PT(3) + DOUBLE PRECISION, INTENT(OUT) :: QP(3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DQ(3,4),DPT(3,3) + DOUBLE PRECISION :: QN, QINV(4),QTMP(4),QTMP2(4) + DOUBLE PRECISION :: MAT(3,3),DMAT(3,3,4) + INTEGER :: I,J + TYPE(QUATERNION) :: QUAT + + QN = DOT_PRODUCT(Q,Q) + QUAT%W = Q(1); QUAT%X = Q(2); QUAT%Y = Q(3); QUAT%Z = Q(4) + IF (PRESENT(DQ)) THEN + CALL QUAT2ROTMAT(QUAT,MAT,dMAT) + ELSE + CALL QUAT2ROTMAT(QUAT,MAT) + ENDIF + DO I = 1,3 + QP(I) = DOT_PRODUCT(MAT(I,:),PT) + IF (PRESENT(DQ)) THEN + DO J = 1,4 + DQ(I,J) = DOT_PRODUCT(dMAT(I,:,J),PT) + ENDDO + ENDIF + ENDDO + + QP = QP/QN + IF (PRESENT(DQ)) THEN + DO I = 1,3 + DO J = 1,4 + DQ(I,J) = (DQ(I,J) - 2*Q(J)*QP(I))/QN + ENDDO + ENDDO + ENDIF + + IF (PRESENT(DPT)) THEN + DPT =MAT/QN + END IF + END SUBROUTINE QVPTMULT + + ! ----------------- STUFF INVOLVING QUATERNION OBJECTS ------------------- + + TYPE(QUATERNION) FUNCTION RHQINTERP(Q1,Q2,F) + ! interpolate from one quaternion to another always in a right-handed sense + ! (relative to the Q1 z-axis) + ! F should be between 0 and 1 + TYPE(QUATERNION) :: Q1, Q2 + DOUBLE PRECISION :: F + DOUBLE PRECISION :: ANG, AX(3), DIR + TYPE(QUATERNION) :: QREL + + ! relative quaternion for Q2 relative to Q1 + QREL = INVQUAT(Q1)*Q2 + + ! angle of rotation + ANG = ACOS(QREL%W)*2 + + ! axis of rotation + AX = (/QREL%X,QREL%Y,QREL%Z/); AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + DIR = DOT_PRODUCT(AX,QUAT2PT(Q1*PTQUAT((/0D0,0D0,1D0/))/Q1)) + + print*, 'testx2:', dir, ang, ax + + IF (DIR.LT.0) THEN + ! rotation axis points away from quaternion axis, so flip it + ANG = -ANG + AX = -AX + ENDIF + + QREL = ROTQUAT(ANG*F,AX) + + RHQINTERP = Q1*QREL + END FUNCTION RHQINTERP + + TYPE(QUATERNION) FUNCTION QSLERP(Q1,Q2,F) + ! Sphreical linear interpolation between two quaternions + ! F should be between 0 and 1 + TYPE(QUATERNION), INTENT(IN) :: Q1, Q2 + DOUBLE PRECISION, INTENT(IN) :: F + DOUBLE PRECISION :: QV1(4), QV2(4), ANG, QVANS(4) + + QV1 = (/Q1%W,Q1%X,Q1%Y,Q1%Z/) + QV2 = (/Q2%W, Q2%X, Q2%Y, Q2%Z/) + + ! angle between them + ANG = ACOS(DOT_PRODUCT(QV1,QV2)) + + QVANS = SIN((1-F)*ANG)/SIN(ANG)*QV1 + SIN(F*ANG)/SIN(ANG)*QV2 + + QSLERP%W = QVANS(1); QSLERP%X = QVANS(2); QSLERP%Y = QVANS(3); QSLERP%Z = QVANS(4); + END FUNCTION QSLERP + + SUBROUTINE QUAT2ROTMAT(Q,MAT,DMAT) + ! convert a quaternion object to a rotation matrix and optionally return derivatives + ! NOTE: no normalization + IMPLICIT NONE + TYPE(QUATERNION) :: Q + DOUBLE PRECISION, INTENT(OUT) :: MAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMAT(3,3,4) + DOUBLE PRECISION :: A,B,C,D,AA,BB,CC,DD,AB,AC,AD,BC,BD,CD + + A = Q%W; B = Q%X; C = Q%Y; D = Q%Z + AA = A*A; BB = B*B; CC = C*C; DD = D*D + AB = 2*A*B; AC = 2*A*C; AD = 2*A*D + BC = 2*B*C; BD = 2*B*D + CD = 2*C*D + + MAT(1,:) = (/AA+BB-CC-DD,BC-AD,AC+BD/) + MAT(2,:) = (/AD+BC,AA-BB+CC-DD,CD-AB/) + MAT(3,:) = (/BD-AC,AB+CD,AA-BB-CC+DD/) + + IF (PRESENT(DMAT)) THEN + dMAT(1,:,1) = (/A,-D,C/) + dMAT(1,:,2) = (/B,C,D/) + dMAT(1,:,3) = (/-C,B,A/) + dMAT(1,:,4) = (/-D,-A,B/) + dMAT(2,:,1) = (/D,A,-B/) + dMAT(2,:,2) = (/C,-B,-A/) + dMAT(2,:,3) = (/B,C,D/) + dMAT(2,:,4) = (/A,-D,C/) + dMAT(3,:,1) = (/-C,B,A/) + dMAT(3,:,2) = (/D,A,-B/) + dMAT(3,:,3) = (/-A,D,-C/) + dMAT(3,:,4) = (/B,C,D/) + dMAT = dMAT*2 + ENDIF + END SUBROUTINE QUAT2ROTMAT + + TYPE(QUATERNION) FUNCTION ROTMAT2QUAT(R) + ! convert from a rotation matrix to a quaternion object + ! following Deibel, 2006 (but with the rotation matrix transposed) + ! R(:,3) has the z axis after rotation is applied, etc. + ! assumes R is orthonormal + IMPLICIT NONE + DOUBLE PRECISION :: R(3,3) + DOUBLE PRECISION :: R11, R22,R33, TMP + + R11 = R(1,1); R22 = R(2,2); R33 = R(3,3) + + IF (R22 .GE.-R33.AND.R11.GE.-R22.AND.R11.GE.-R33) THEN + TMP = SQRT(1+R11+R22+R33) + ROTMAT2QUAT%W = TMP/2 + ROTMAT2QUAT%X = (R(3,2)-R(2,3))/(TMP*2) + ROTMAT2QUAT%Y = (R(1,3)-R(3,1))/(TMP*2) + ROTMAT2QUAT%Z = (R(2,1)-R(1,2))/(TMP*2) + !PRINT*, 'TESTX1Q' + ELSEIF (R22.LE.-R33.AND.R11.GT.R22.AND.R11.GT.R33) THEN + TMP = SQRT(1+R11-R22-R33) + ROTMAT2QUAT%W = (R(3,2)-R(2,3))/(TMP*2) + ROTMAT2QUAT%X = TMP/2 + ROTMAT2QUAT%Y = (R(2,1)+R(1,2))/(TMP*2) + ROTMAT2QUAT%Z = (R(1,3)+R(3,1))/(TMP*2) + !PRINT*, 'TESTX2Q' + ELSEIF (R22.GT.R33.AND.R11.LT.R22.AND.R11.LE.-R33) THEN + TMP = SQRT(1-R11+R22-R33) + ROTMAT2QUAT%W = (R(1,3)-R(3,1))/(TMP*2) + ROTMAT2QUAT%X = (R(2,1)+R(1,2))/(TMP*2) + ROTMAT2QUAT%Y = TMP/2 + ROTMAT2QUAT%Z = (R(3,2)+R(2,3))/(TMP*2) + !PRINT*, 'TESTX3Q' + ELSEIF (R22.LT.R33.AND.R11.LE.-R22.AND.R11.LT.R33) THEN + TMP = SQRT(1D0-R11-R22+R33) + ROTMAT2QUAT%W = (R(2,1)-R(1,2))/(TMP*2) + ROTMAT2QUAT%X = (R(1,3)+R(3,1))/(TMP*2) + ROTMAT2QUAT%Y = (R(3,2)+R(2,3))/(TMP*2) + ROTMAT2QUAT%Z = TMP/2 + !PRINT*, 'TESTX4Q' + ELSE + PRINT*, 'ERROR IN ROTMAT2QUAT: bad rotation matrix' + PRINT*, R(1,:) + PRINT*, R(2,:) + PRINT*, R(3,:) + STOP 1 + ROTMAT2QUAT%W = 0; ROTMAT2QUAT%X = 0; ROTMAT2QUAT%Y = 0; ROTMAT2QUAT%Z = 0 + ENDIF + END FUNCTION ROTMAT2QUAT + + SUBROUTINE EULER2QUAT(EUL,Q,DERV,GETDERV) + ! convert from Euler angles (z-x-z convention) to a quaternion + ! if GETDERV is true, also get the derivatives of the quaternion components + ! with respect to the euler angles (4 rows by 3 columns) + ! WARNING: since the quaternion representation has more parameters, switching from quaternion + ! to euler and back again will not always give the exact same quaternion, though it + ! will give an equivalent one (eg: may invert all components) + + DOUBLE PRECISION, INTENT(IN) :: EUL(3) + TYPE(QUATERNION), INTENT(OUT) :: Q + DOUBLE PRECISION, INTENT(OUT),OPTIONAL :: DERV(4,3) + LOGICAL, INTENT(IN),OPTIONAL :: GETDERV + DOUBLE PRECISION :: CA,SA,CB,SB,CG,SG,ALPHA,GAMMA,BETA + LOGICAL :: FLIPBETA + + BETA = ANGLE2PI(EUL(2)) + FLIPBETA = BETA.GT.PI + ALPHA = EUL(1); GAMMA = EUL(3) + IF (BETA.GT.PI) THEN + BETA = 2*PI-BETA + GAMMA = GAMMA+PI + ALPHA = ALPHA+PI + ENDIF + + ALPHA = ANGLE2PI(ALPHA) + GAMMA = ANGLE2PI(GAMMA) + !IF (QUATTEST) THEN + ! PRINT*, 'TESTXE:', EUL + ! PRINT*, 'A,B,G:',ALPHA,BETA,GAMMA + !ENDIF + + CA = COS(ALPHA/2); SA = SIN(ALPHA/2) + CB = COS(BETA/2); SB = SIN(BETA/2) + CG = COS(GAMMA/2); SG = SIN(GAMMA/2) + + Q%W = CG*CB*CA - SG*CB*SA + Q%X = SG*SB*SA + CG*SB*CA + Q%Y = CG*SB*SA - SG*SB*CA + Q%Z = CG*CB*SA + SG*CB*CA + + IF (PRESENT(DERV)) THEN + IF (GETDERV) THEN + DERV(1,:) = 0.5D0*(/-CG*CB*SA - SG*CB*CA, -CG*SB*CA + SG*SB*SA, -SG*CB*CA - CG*CB*SA/) + DERV(2,:) = 0.5D0*(/SG*SB*CA - CG*SB*SA, SG*CB*SA + CG*CB*CA, CG*SB*SA - SG*SB*CA /) + DERV(3,:) = 0.5D0*(/CG*SB*CA + SG*SB*SA, CG*CB*SA - SG*CB*CA, -SG*SB*SA - CG*SB*CA/) + DERV(4,:) = 0.5D0*(/CG*CB*CA - SG*CB*SA, -CG*SB*SA - SG*SB*CA, -SG*CB*SA + CG*CB*CA/) + ENDIF + IF (FLIPBETA) THEN + DERV(:,2) = -DERV(:,2) + ENDIF + ENDIF + + END SUBROUTINE EULER2QUAT + + SUBROUTINE QUAT2EULER(Q,EUL) + ! get the Euler angles (z-x-z convention) corresponding to a unit quaternion + ! NOTE: the quaternion must already be normalized + ! currently can't handle gimbal lock + TYPE(QUATERNION), INTENT(IN) :: Q + DOUBLE PRECISION, INTENT(OUT) :: EUL(3) + DOUBLE PRECISION :: DUMMY + + EUL(2) = 1 - 2*(Q%X**2+Q%Y**2) + IF (EUL(2).GT.1) THEN + EUL(2) = 0D0 + ELSEIF (EUL(2).LT.-1) THEN + EUL(2) = PI + ELSE + EUL(2) = ACOS(EUL(2)) + ENDIF + + ! deal with the gimbal lock issues + IF (EUL(2).LE.EPSILON(0D0)) THEN + EUL(3) = ATAN2(2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2+Q%Z**2)) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + EUL(1) = 0D0 + RETURN + ELSEIF (EUL(2).GE.PI-EPSILON(0D0)) THEN + EUL(3) = ATAN2(-2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2+Q%Z**2)) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + EUL(1) = 0D0 + RETURN + ENDIF + + DUMMY = Q%W*Q%X-Q%Y*Q%Z + + EUL(1) = ATAN2(Q%W*Q%Y+Q%X*Q%Z, DUMMY) + IF (EUL(1).LT.0) EUL(1) = 2*PI+EUL(1) + + DUMMY = Q%W*Q%X+Q%Y*Q%Z + + EUL(3) = ATAN2(Q%X*Q%Z-Q%W*Q%Y,DUMMY) + IF (EUL(3).LT.0) EUL(3) = 2*PI+EUL(3) + + END SUBROUTINE QUAT2EULER + + FUNCTION QUAT2PT(Q) + ! get the point corresponding to a quaternion + TYPE(QUATERNION) :: Q + DOUBLE PRECISION :: QUAT2PT(3) + + QUAT2PT = (/Q%X,Q%Y,Q%Z/) + END FUNCTION QUAT2PT + + TYPE(QUATERNION) FUNCTION ROTQUAT(THETA,AX) + ! get the quaternion corresponding to rotation around unit axis AX + ! by an angle theta + DOUBLE PRECISION :: THETA, AX(3) + DOUBLE PRECISION :: T2, ST2 + + IF (ABS(SUM(AX**2)-1D0).GT.EPSILON(1d0)*10) THEN + print*, 'ERROR in ROTQUAT: Axis does not have unit norm' + STOP 1 + ENDIF + + T2 = THETA/2; ST2 = SIN(THETA/2) + ROTQUAT%W = COS(T2) + ROTQUAT%X = ST2*AX(1); ROTQUAT%Y = ST2*AX(2); ROTQUAT%Z=ST2*AX(3) + END FUNCTION ROTQUAT + + TYPE(QUATERNION) FUNCTION PTQUAT(P) + ! turn a 3d point into a quaternion + DOUBLE PRECISION :: P(3) + + PTQUAT%W = 0D0; PTQUAT%X = P(1); PTQUAT%Y = P(2); PTQUAT%Z = P(3) + END FUNCTION PTQUAT + + TYPE(QUATERNION) FUNCTION INVQUAT(Q) + ! get the inverse of a quaternion + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: Q + DOUBLE PRECISION :: QN + + QN = Q%W**2+Q%X**2+Q%Y**2+Q%Z**2 + INVQUAT%W = Q%W/QN; INVQUAT%X = -Q%X/QN; INVQUAT%Y=-Q%Y/QN; INVQUAT%Z=-Q%Z/QN + + END FUNCTION INVQUAT + + TYPE(QUATERNION) FUNCTION QDIVIDE(P,Q) + ! multiply P by inverse of Q(in that order) + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: P,Q + TYPE(QUATERNION) :: QINV + DOUBLE PRECISION :: QN + + ! inverse of the 2nd quaternion + QN = Q%W**2+Q%X**2+Q%Y**2+Q%Z**2 + QINV%W = Q%W/QN; QINV%X = -Q%X/QN; QINV%Y=-Q%Y/QN; QINV%Z=-Q%Z/QN + + QDIVIDE = P*QINV + END FUNCTION QDIVIDE + + TYPE(QUATERNION) FUNCTION QPRODUCT(P,Q) + ! quaternion multiplication + IMPLICIT NONE + TYPE(QUATERNION), INTENT(IN) :: P, Q + + QPRODUCT%W = P%W*Q%W - P%X*Q%X - P%Y*Q%Y - P%Z*Q%Z + QPRODUCT%X = P%W*Q%X + P%X*Q%W + P%Y*Q%Z - P%Z*Q%Y + QPRODUCT%Y = P%W*Q%Y - P%X*Q%Z + P%Y*Q%W + P%Z*Q%X + QPRODUCT%Z = P%W*Q%Z + P%X*Q%Y - P%Y*Q%X + P%Z*Q%W + + END FUNCTION QPRODUCT + + ! --------- general angle and euler angle stuff ------------- + SUBROUTINE ROTANGAX(ANG,AX,INVEC,OUTVEC,CALCROTMAT,ROTMAT) + ! rotate a 3D vector by angle ANG around axis AX + ! if CALCROTMAT is true, recalculate the rotation matrix + ! otherwise use the provided one + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: ANG, AX(3), INVEC(3) + DOUBLE PRECISION, INTENT(OUT) :: OUTVEC(3) + DOUBLE PRECISION, INTENT(INOUT) :: ROTMAT(3,3) + LOGICAL, INTENT(IN) :: CALCROTMAT + DOUBLE PRECISION :: CT,ST,CT1 + INTEGER :: I + + IF (CALCROTMAT) THEN + CT = COS(ANG); ST = SIN(ANG) + CT1 = 1-CT + ROTMAT(1,:) = (/CT + AX(1)**2*CT1, AX(1)*AX(2)*CT1-AX(3)*ST, AX(1)*AX(3)*CT1+AX(2)*ST/) + ROTMAT(2,:) = (/AX(2)*AX(1)*CT1+AX(3)*ST,CT+AX(2)**2*CT1,AX(2)*AX(3)*CT1-AX(1)*ST/) + ROTMAT(3,:) = (/AX(3)*AX(1)*CT1-AX(2)*ST,AX(3)*AX(2)*CT1+AX(1)*ST, CT+AX(3)**2*CT1/) + ENDIF + + DO I = 1,3 + OUTVEC(I) = DOT_PRODUCT(ROTMAT(I,:),INVEC) + ENDDO + END SUBROUTINE ROTANGAX + + SUBROUTINE EUL2ROTMAT(EUL,ROTMAT,DMAT) + ! get the rotation matrix corresponding to various euler angles + ! and the appropriate derivatives if DMAT is present + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: EUL(3) + DOUBLE PRECISION, INTENT(OUT) :: ROTMAT(3,3) + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: DMAT(3,3,3) + DOUBLE PRECISION :: CA,SA,CB,SB,CG,SG + + CA = COS(EUL(1)); SA = SIN(EUL(1)) + CB = COS(EUL(2)); SB = SIN(EUL(2)) + CG = COS(EUL(3)); SG = SIN(EUL(3)) + + ROTMAT(1,:) = (/CA*CG-SA*CB*SG, -CA*SG-SA*CB*CG, SB*SA/) + ROTMAT(2,:) = (/SA*CG+CA*CB*SG,-SA*SG+CA*CB*CG,-SB*CA/) + ROTMAT(3,:) = (/SB*SG,SB*CG,CB/) + + IF (PRESENT(DMAT)) THEN + dMAT(1,:,1) = (/-SA*CG-CA*CB*SG,SA*SG-CA*CB*CG,SB*CA/) + dMAT(2,:,1) = (/CA*CG-SA*CB*SG,-CA*SG-SA*CB*CG,SB*SA/) + dMAT(3,:,1) = 0D0 + + dMAT(1,:,2) = (/SA*SB*SG,SA*SB*CG,CB*SA/) + dMAT(2,:,2) = (/-CA*SB*SG,-CA*SB*CG,-CB*CA/) + dMAT(3,:,2) = (/CB*SG,CB*CG,-SB/) + + dMAT(1,:,3) = (/-CA*SG-SA*CB*CG,-CA*CG+SA*CB*SG,0D0/) + dMAT(2,:,3) = (/-SA*SG+CA*CB*CG,-SA*CG-CA*CB*SG,0D0/) + dMAT(3,:,3) = (/SB*CG,-SB*SG,0D0/) + ENDIF + END SUBROUTINE EUL2ROTMAT + + SUBROUTINE GETANGLE(IJ,KJ,CST,dCTdIJ,dCTdKJ) + ! get the angle between three points (I-J-K) + ! and, optionally, the derivative of that angle + ! actually this returns the COSINE of the angle and its derivative + ! IJ = I-J; KJ = K-J + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: IJ(3),KJ(3) + DOUBLE PRECISION, INTENT(OUT) :: CST + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: dCTdIJ(3), dCTdKJ(3) + + DOUBLE PRECISION :: DXI, DYI, DZI, DXJ, DYJ, DZJ + DOUBLE PRECISION :: RI2, RJ2, RI, RJ, RIR, RJR + DOUBLE PRECISION :: DXIR,DYIR, DZIR,DXJR,DYJR,DZJR + + DXI=IJ(1); DYI = IJ(2); DZI = IJ(3) + DXJ = KJ(1); DYJ = KJ(2); DZJ = KJ(3) + + RI2=DXI*DXI+DYI*DYI+DZI*DZI + RJ2=DXJ*DXJ+DYJ*DYJ+DZJ*DZJ + RI=SQRT(RI2) + RJ=SQRT(RJ2) + RIR=1/RI + RJR=1/RJ + DXIR=DXI*RIR + DYIR=DYI*RIR + DZIR=DZI*RIR + DXJR=DXJ*RJR + DYJR=DYJ*RJR + DZJR=DZJ*RJR + CST=DXIR*DXJR+DYIR*DYJR+DZIR*DZJR + IF (PRESENT(DCTDIJ)) THEN + dCTdIJ(1)=-(DXIR*CST-DXJR)*RIR + dCTdIJ(2)=-(DYIR*CST-DYJR)*RIR + dCTdIJ(3)=-(DZIR*CST-DZJR)*RIR + ENDIF + IF (PRESENT(DCTDKJ)) THEN + dCTdKJ(1)=-(DXJR*CST-DXIR)*RJR + dCTdKJ(2)=-(DYJR*CST-DYIR)*RJR + dCTdKJ(3)=-(DZJR*CST-DZIR)*RJR + ENDIF + + END SUBROUTINE GETANGLE + + SUBROUTINE GETDIHEDRAL(IJ,JK,LK, PHI, dPdIJ, dPdJK, dPdLK) + ! dihedral angle for 4 atoms I, J, K, L bound in order + ! IJ = I-J; JK = J-K; LK = L-K + ! find the dihedral torsion angle; return it in PHI + ! Also return all derivatives: dP/dIJx, dP/dIJy, dP/dIJz in triplet dPdIJ + ! same with dPdJK, dPdLK + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: IJ(3), JK(3), LK(3) + DOUBLE PRECISION, INTENT(OUT) :: PHI + DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: dPdIJ(3), dPdJK(3), dPdLK(3) + DOUBLE PRECISION :: DPDJ(3),DPDI(3),DPDK(3),DPDL(3) + DOUBLE PRECISION :: FX, FY, FZ, GX, GY, GZ, HX, HY, HZ + DOUBLE PRECISION :: AX, AY, AZ, BX, BY, Bz + DOUBLE PRECISION :: RF, RG, RH, RF2, RG2, RH2, RFR, RGR, RHR + DOUBLE PRECISION :: CSTTWO, SNTTWO2, CSTTHREE, SNTTHREE2, SNTTWO2R, SNTTHREE2R + DOUBLE PRECISION :: RA2, RB2, RA2R, RB2R, RABR, CP + DOUBLE PRECISION :: MYTX, MYTY, MYTZ, MYSCALAR + DOUBLE PRECISION :: DUMMY, DUMMY2 + DOUBLE PRECISION :: B1(3), B2(3), B3(3), B12(3), B23(3) + LOGICAL :: NOCOOR = .FALSE. + + + FX=IJ(1) + FY=IJ(2) + FZ=IJ(3) + GX=JK(1) + GY=JK(2) + GZ=JK(3) + HX=LK(1) + HY=LK(2) + HZ=LK(3) + ! A=F x G, B=H x G + AX=FY*GZ-FZ*GY + AY=FZ*GX-FX*GZ + AZ=FX*GY-FY*GX + BX=HY*GZ-HZ*GY + BY=HZ*GX-HX*GZ + BZ=HX*GY-HY*GX + ! RG=|G|, RGR=1/|G| + RG2=GX*GX+GY*GY+GZ*GZ + RG=SQRT(RG2) + RGR=1/RG + ! dae for use in evaluating B-matrix + RF2=FX*FX+FY*FY+FZ*FZ + RF=SQRT(RF2) + RFR=1/RF + RH2=HX*HX+HY*HY+HZ*HZ + RH=SQRT(RH2) + RHR=1/RH + + + CSTTWO=-(FX*GX+FY*GY+FZ*GZ)*RFR*RGR + SNTTWO2=1-CSTTWO*CSTTWO + SNTTWO2R=1/SNTTWO2 + CSTTHREE=(HX*GX+HY*GY+HZ*GZ)*RHR*RGR + SNTTHREE2=1-CSTTHREE*CSTTHREE + SNTTHREE2R=1/SNTTHREE2 + + RA2=AX*AX+AY*AY+AZ*AZ + RB2=BX*BX+BY*BY+BZ*BZ + RA2R=1/RA2 + RB2R=1/RB2 + RABR=SQRT(RA2R*RB2R) + + PHI = ATAN2(-RG*(FX*BX+FY*BY+FZ*BZ),AX*BX+AY*BY+AZ*BZ) + + + IF (PRESENT(DPDIJ).OR.PRESENT(DPDJK).OR.PRESENT(DPDLK)) THEN + DUMMY=RFR*RFR*RGR*SNTTWO2R + dPdI = (/-AX*DUMMY, -AY*DUMMY, -AZ*DUMMY/) + DUMMY=RFR*RFR*RGR*RGR*SNTTWO2R*(RG-RF*CSTTWO) + DUMMY2=RHR*RGR*RGR*SNTTHREE2R*CSTTHREE + dPdJ = (/AX*DUMMY-BX*DUMMY2, AY*DUMMY-BY*DUMMY2, AZ*DUMMY-BZ*DUMMY2/) + DUMMY=RHR*RHR*RGR*SNTTHREE2R + dPdL = (/BX*DUMMY,BY*DUMMY,BZ*DUMMY/) + ENDIF + IF (PRESENT(DPDIJ)) DPDIJ = DPDI + IF (PRESENT(DPDLK)) DPDLK = DPDL + IF (PRESENT(DPDJK)) DPDJK = DPDI + DPDJ + + + END SUBROUTINE GETDIHEDRAL + + DOUBLE PRECISION FUNCTION ANGLE0(ANGLE) + ! convert an angle to one between +/- pi + ! (so keeping it as close as possible to zero) + IMPLICIT NONE + DOUBLE PRECISION :: ANGLE + + ANGLE0 = ANGLE2PI(ANGLE) + IF (ANGLE0.GT.PI) THEN + ANGLE0 = ANGLE0 - 2*PI + ENDIF + END FUNCTION ANGLE0 + + DOUBLE PRECISION FUNCTION ANGLE2PI(ANGLE) + ! convert an angle to one between 0 and 2pi by adding or subtracting multiples of 2pi + IMPLICIT NONE + DOUBLE PRECISION :: ANGLE + INTEGER :: N2PI + + N2PI = INT(ANGLE/(2*PI)) + IF (ANGLE.LT.0) THEN + ANGLE2PI = ANGLE+(-N2PI+1)*2*PI + ELSE + ANGLE2PI = ANGLE - N2PI*2*PI + ENDIF + END FUNCTION ANGLE2PI + +END MODULE QUATUTIL diff --git a/BasicWLC/dssWLC/source/ranlib.f90 b/BasicWLC/dssWLC/source/ranlib.f90 new file mode 100644 index 00000000..f21e9d93 --- /dev/null +++ b/BasicWLC/dssWLC/source/ranlib.f90 @@ -0,0 +1,3281 @@ +! EFK 2013/05/01: Downloaded from http://people.sc.fsu.edu/~jburkardt/f_src/ranlib/ranlib.html + +function genbet ( aa, bb ) + +!*****************************************************************************80 +! +!! GENBET generates a beta random deviate. +! +! Discussion: +! +! This procedure returns a single random deviate from the beta distribution +! with parameters A and B. The density is +! +! x^(a-1) * (1-x)^(b-1) / Beta(a,b) for 0 < x < 1 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 April 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Russell Cheng, +! Generating Beta Variates with Nonintegral Shape Parameters, +! Communications of the ACM, +! Volume 21, Number 4, April 1978, pages 317-322. +! +! Parameters: +! +! Input, real ( kind = 4 ) AA, the first parameter of the beta distribution. +! 0.0 < AA. +! +! Input, real ( kind = 4 ) BB, the second parameter of the beta distribution. +! 0.0 < BB. +! +! Output, real ( kind = 4 ) GENBET, a beta random variate. +! + implicit none + + real ( kind = 4 ) a + real ( kind = 4 ) aa + real ( kind = 4 ) alpha + real ( kind = 4 ) b + real ( kind = 4 ) bb + real ( kind = 4 ) beta + real ( kind = 4 ) delta + real ( kind = 4 ) gamma + real ( kind = 4 ) genbet + real ( kind = 4 ) k1 + real ( kind = 4 ) k2 + real ( kind = 4 ), parameter :: log4 = 1.3862943611198906188E+00 + real ( kind = 4 ), parameter :: log5 = 1.6094379124341003746E+00 + real ( kind = 4 ) r + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) s + real ( kind = 4 ) t + real ( kind = 4 ) u1 + real ( kind = 4 ) u2 + real ( kind = 4 ) v + real ( kind = 4 ) w + real ( kind = 4 ) y + real ( kind = 4 ) z + + if ( aa <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENBET - Fatal error!' + write ( *, '(a)' ) ' AA <= 0.0' + stop + end if + + if ( bb <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENBET - Fatal error!' + write ( *, '(a)' ) ' BB <= 0.0' + stop + end if +! +! Algorithm BB +! + if ( 1.0E+00 < aa .and. 1.0E+00 < bb ) then + + a = min ( aa, bb ) + b = max ( aa, bb ) + alpha = a + b + beta = sqrt ( ( alpha - 2.0E+00 ) / ( 2.0E+00 * a * b - alpha ) ) + gamma = a + 1.0E+00 / beta + + do + + u1 = r4_uniform_01 ( ) + u2 = r4_uniform_01 ( ) + v = beta * log ( u1 / ( 1.0E+00 - u1 ) ) + w = a * exp ( v ) + + z = u1 ** 2 * u2 + r = gamma * v - log4 + s = a + r - w + + if ( 5.0E+00 * z <= s + 1.0E+00 + log5 ) then + exit + end if + + t = log ( z ) + if ( t <= s ) then + exit + end if + + if ( t <= ( r + alpha * log ( alpha / ( b + w ) ) ) ) then + exit + end if + + end do +! +! Algorithm BC +! + else + + a = max ( aa, bb ) + b = min ( aa, bb ) + alpha = a + b + beta = 1.0E+00 / b + delta = 1.0E+00 + a - b + k1 = delta * ( 1.0E+00 / 72.0E+00 + b / 24.0E+00 ) & + / ( a / b - 7.0E+00 / 9.0E+00 ) + k2 = 0.25E+00 + ( 0.5E+00 + 0.25E+00 / delta ) * b + + do + + u1 = r4_uniform_01 ( ) + u2 = r4_uniform_01 ( ) + + if ( u1 < 0.5E+00 ) then + + y = u1 * u2 + z = u1 * y + + if ( k1 <= 0.25E+00 * u2 + z - y ) then + cycle + end if + + else + + z = u1 ** 2 * u2 + + if ( z <= 0.25E+00 ) then + + v = beta * log ( u1 / ( 1.0E+00 - u1 ) ) + w = a * exp ( v ) + + if ( aa == a ) then + genbet = w / ( b + w ) + else + genbet = b / ( b + w ) + end if + + return + + end if + + if ( k2 < z ) then + cycle + end if + + end if + + v = beta * log ( u1 / ( 1.0E+00 - u1 ) ) + w = a * exp ( v ) + + if ( log ( z ) <= alpha * ( log ( alpha / ( b + w ) ) + v ) - log4 ) then + exit + end if + + end do + + end if + + if ( aa == a ) then + genbet = w / ( b + w ) + else + genbet = b / ( b + w ) + end if + + return +end +function genchi ( df ) + +!*****************************************************************************80 +! +!! GENCHI generates a Chi-Square random deviate. +! +! Discussion: +! +! This procedure generates a random deviate from the chi square distribution +! with DF degrees of freedom random variable. +! +! The algorithm exploits the relation between chisquare and gamma. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) DF, the degrees of freedom. +! 0.0 < DF. +! +! Output, real ( kind = 4 ) GENCHI, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) arg1 + real ( kind = 4 ) arg2 + real ( kind = 4 ) df + real ( kind = 4 ) genchi + real ( kind = 4 ) gengam + + if ( df <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENCHI - Fatal error!' + write ( *, '(a)' ) ' DF <= 0.' + write ( *, '(a,g14.6)' ) ' Value of DF: ', df + stop + end if + + arg1 = 1.0E+00 + arg2 = df / 2.0E+00 + + genchi = 2.0E+00 * gengam ( arg1, arg2 ) + + return +end +function genexp ( av ) + +!*****************************************************************************80 +! +!! GENEXP generates an exponential random deviate. +! +! Discussion: +! +! This procedure generates a single random deviate from an exponential +! distribution with mean AV. +! +! See also the function R4_EXPONENTIAL_SAMPLE. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Computer Methods for Sampling From the +! Exponential and Normal Distributions, +! Communications of the ACM, +! Volume 15, Number 10, October 1972, pages 873-882. +! +! Parameters: +! +! Input, real ( kind = 4 ) AV, the mean of the exponential distribution +! from which a random deviate is to be generated. +! +! Output, real ( kind = 4 ) GENEXP, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) av + real ( kind = 4 ) genexp + real ( kind = 4 ) sexpo + + genexp = sexpo ( ) * av + + return +end +function genf ( dfn, dfd ) + +!*****************************************************************************80 +! +!! GENF generates an F random deviate. +! +! Discussion: +! +! This procedure generates a random deviate from the F (variance ratio) +! distribution with DFN degrees of freedom in the numerator +! and DFD degrees of freedom in the denominator. +! +! It directly generates the ratio of chisquare variates +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) DFN, the numerator degrees of freedom. +! 0.0 < DFN. +! +! Input, real ( kind = 4 ) DFD, the denominator degrees of freedom. +! 0.0 < DFD. +! +! Output, real ( kind = 4 ) GENF, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) dfd + real ( kind = 4 ) dfn + real ( kind = 4 ) genchi + real ( kind = 4 ) genf + real ( kind = 4 ) xden + real ( kind = 4 ) xnum + + if ( dfn <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENF - Fatal error!' + write ( *, '(a)' ) ' DFN <= 0.0' + stop + end if + + if ( dfd <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENF - Fatal error!' + write ( *, '(a)' ) ' DFD <= 0.0' + stop + end if + + xnum = genchi ( dfn ) / dfn + xden = genchi ( dfd ) / dfd + genf = xnum / xden + + return +end +function gengam ( a, r ) + +!*****************************************************************************80 +! +!! GENGAM generates a Gamma random deviate. +! +! Discussion: +! +! This procedure generates random deviates from the gamma distribution whose +! density is (A^R)/Gamma(R) * X^(R-1) * Exp(-A*X) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Generating Gamma Variates by a Modified Rejection Technique, +! Communications of the ACM, +! Volume 25, Number 1, January 1982, pages 47-54. +! +! Joachim Ahrens, Ulrich Dieter, +! Computer Methods for Sampling from Gamma, Beta, Poisson and +! Binomial Distributions, +! Computing, +! Volume 12, Number 3, September 1974, pages 223-246. +! +! Parameters: +! +! Input, real ( kind = 4 ) A, the location parameter. +! +! Input, real ( kind = 4 ) R, the shape parameter. +! +! Output, real ( kind = 4 ) GENGAM, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) a + real ( kind = 4 ) gengam + real ( kind = 4 ) r + real ( kind = 4 ) sgamma + + gengam = sgamma ( r ) / a + + return +end +subroutine genmn ( parm, x, work ) + +!*****************************************************************************80 +! +!! GENMN generates a multivariate normal deviate. +! +! Discussion: +! +! The method is: +! 1) Generate P independent standard normal deviates - Ei ~ N(0,1) +! 2) Using Cholesky decomposition find A so that A'*A = COVM +! 3) A' * E + MEANV ~ N(MEANV,COVM) +! +! Note that PARM contains information needed to generate the +! deviates, and is set up by SETGMN. +! +! PARM(1) contains the size of the deviates, P +! PARM(2:P+1) contains the mean vector. +! PARM(P+2:P*(P+3)/2+1) contains the upper half of the Cholesky +! decomposition of the covariance matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) PARM(P*(P+3)/2+1), parameters set by SETGMN. +! +! Output, real ( kind = 4 ) X(P), a random deviate from the distribution. +! +! Workspace, real ( kind = 4 ) WORK(P). +! + implicit none + + real ( kind = 4 ) ae + integer ( kind = 4 ) i + integer ( kind = 4 ) icount + integer ( kind = 4 ) j + integer ( kind = 4 ) p + real ( kind = 4 ) parm(*) + real ( kind = 4 ) snorm + real ( kind = 4 ) work(*) + real ( kind = 4 ) x(*) + + p = int ( parm(1) ) +! +! Generate P independent normal deviates. +! + do i = 1, p + work(i) = snorm ( ) + end do +! +! Compute X = MEANV + A' * WORK +! + do i = 1, p + icount = 0 + ae = 0.0E+00 + do j = 1, i + icount = icount + j - 1 + ae = ae + parm(i+(j-1)*p-icount+p+1) * work(j) + end do + + x(i) = ae + parm(i+1) + + end do + + return +end +subroutine genmul ( n, p, ncat, ix ) + +!*****************************************************************************80 +! +!! GENMUL generates a multinomial random deviate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Luc Devroye, +! Non-Uniform Random Variate Generation, +! Springer, 1986, +! ISBN: 0387963057, +! LC: QA274.D48. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of events, which will be +! classified into one of the NCAT categories. +! +! Input, real ( kind = 4 ) P(NCAT-1). P(I) is the probability that an event +! will be classified into category I. Thus, each P(I) must be between +! 0.0 and 1.0. Only the first NCAT-1 values of P must be defined since +! P(NCAT) would be 1.0 minus the sum of the first NCAT-1 P's. +! +! Input, integer ( kind = 4 ) NCAT, the number of categories. +! +! Output, integer ( kind = 4 ) IX(NCAT), a random observation from +! the multinomial distribution. All IX(i) will be nonnegative and their +! sum will be N. +! + implicit none + + integer ( kind = 4 ) n + integer ( kind = 4 ) ncat + + integer ( kind = 4 ) i + integer ( kind = 4 ) icat + integer ( kind = 4 ) ignbin + integer ( kind = 4 ) ix(ncat) + integer ( kind = 4 ) ntot + real ( kind = 4 ) p(ncat-1) + real ( kind = 4 ) prob + real ( kind = 4 ) ptot + + if ( n < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENMUL - Fatal error!' + write ( *, '(a)' ) ' N < 0' + stop + end if + + if ( ncat <= 1 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENMUL - Fatal error!' + write ( *, '(a)' ) ' NCAT <= 1' + stop + end if + + do i = 1, ncat - 1 + + if ( p(i) < 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENMUL - Fatal error!' + write ( *, '(a)' ) ' Some P(i) < 0.' + stop + end if + + if ( 1.0E+00 < p(i) ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENMUL - Fatal error!' + write ( *, '(a)' ) ' Some 1 < P(i).' + stop + end if + + end do + + ptot = 0.0E+00 + do i = 1, ncat - 1 + ptot = ptot + p(i) + end do + + if ( 0.99999E+00 < ptot ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENMUL - Fatal error!' + write ( *, '(a)' ) ' 1 < Sum of P().' + stop + end if +! +! Initialize variables. +! + ntot = n + ptot = 1.0E+00 + do i = 1, ncat + ix(i) = 0 + end do +! +! Generate the observation. +! + do icat = 1, ncat - 1 + prob = p(icat) / ptot + ix(icat) = ignbin ( ntot, prob ) + ntot = ntot - ix(icat) + if ( ntot <= 0 ) then + return + end if + ptot = ptot - p(icat) + end do + + ix(ncat) = ntot + + return +end +function gennch ( df, xnonc ) + +!*****************************************************************************80 +! +!! GENNCH generates a noncentral Chi-Square random deviate. +! +! Discussion: +! +! This procedure generates a random deviate from the distribution of a +! noncentral chisquare with DF degrees of freedom and noncentrality parameter +! XNONC. +! +! It uses the fact that the noncentral chisquare is the sum of a chisquare +! deviate with DF-1 degrees of freedom plus the square of a normal +! deviate with mean XNONC and standard deviation 1. +! +! A subtle ambiguity arises in the original formulation: +! +! gennch = genchi ( arg1 ) + ( gennor ( arg2, arg3 ) ) ^ 2 +! +! because the compiler is free to invoke either genchi or gennor +! first, both of which alter the random number generator state, +! resulting in two distinct possible results. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) DF, the degrees of freedom. +! 1.0 < DF. +! +! Input, real ( kind = 4 ) XNONC, the noncentrality parameter. +! 0.0 <= XNONC. +! +! Output, real ( kind = 4 ) GENNCH, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) arg1 + real ( kind = 4 ) arg2 + real ( kind = 4 ) arg3 + real ( kind = 4 ) df + real ( kind = 4 ) genchi + real ( kind = 4 ) gennch + real ( kind = 4 ) gennor + real ( kind = 4 ) t1 + real ( kind = 4 ) t2 + real ( kind = 4 ) xnonc + + if ( df <= 1.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENNCH - Fatal error!' + write ( *, '(a)' ) ' DF <= 1.' + stop + end if + + if ( xnonc < 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENNCH - Fatal error!' + write ( *, '(a)' ) ' XNONC < 0.0.' + stop + end if + + arg1 = df - 1.0E+00 + arg2 = sqrt ( xnonc ) + arg3 = 1.0E+00 + + t1 = genchi ( arg1 ) + t2 = gennor ( arg2, arg3 ) + + gennch = t1 + t2 * t2 + + return +end +function gennf ( dfn, dfd, xnonc ) + +!*****************************************************************************80 +! +!! GENNF generates a noncentral F random deviate. +! +! Discussion: +! +! This procedure generates a random deviate from the noncentral F +! (variance ratio) distribution with DFN degrees of freedom in the +! numerator, and DFD degrees of freedom in the denominator, and +! noncentrality parameter XNONC. +! +! It directly generates the ratio of noncentral numerator chisquare variate +! to central denominator chisquare variate. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) DFN, the numerator degrees of freedom. +! 1.0 < DFN. +! +! Input, real ( kind = 4 ) DFD, the denominator degrees of freedom. +! 0.0 < DFD. +! +! Input, real ( kind = 4 ) XNONC, the noncentrality parameter. +! 0.0 <= XNONC. +! +! Output, real ( kind = 4 ) GENNF, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) dfd + real ( kind = 4 ) dfn + real ( kind = 4 ) genchi + real ( kind = 4 ) gennch + real ( kind = 4 ) gennf + real ( kind = 4 ) xden + real ( kind = 4 ) xnonc + real ( kind = 4 ) xnum + + if ( dfn <= 1.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENNF - Fatal error!' + write ( *, '(a)' ) ' DFN <= 1.0' + stop + end if + + if ( dfd <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENNF - Fatal error!' + write ( *, '(a)' ) ' DFD <= 0.0' + stop + end if + + if ( xnonc < 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'GENNF - Fatal error!' + write ( *, '(a)' ) ' XNONC < 0.0' + stop + end if + + xnum = gennch ( dfn, xnonc ) / dfn + xden = genchi ( dfd ) / dfd + + gennf = xnum / xden + + return +end +function gennor ( av, sd ) + +!*****************************************************************************80 +! +!! GENNOR generates a normal random deviate. +! +! Discussion: +! +! This procedure generates a single random deviate from a normal distribution +! with mean AV, and standard deviation SD. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Extensions of Forsythe's Method for Random +! Sampling from the Normal Distribution, +! Mathematics of Computation, +! Volume 27, Number 124, October 1973, page 927-937. +! +! Parameters: +! +! Input, real ( kind = 4 ) AV, the mean. +! +! Input, real ( kind = 4 ) SD, the standard deviation. +! +! Output, real ( kind = 4 ) GENNOR, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) av + real ( kind = 4 ) gennor + real ( kind = 4 ) sd + real ( kind = 4 ) snorm + + gennor = sd * snorm ( ) + av + + return +end +subroutine genprm ( iarray, n ) + +!*****************************************************************************80 +! +!! GENPRM generates and applies a random permutation to an array. +! +! Discussion: +! +! To see the permutation explicitly, let the input array be +! 1, 2, ..., N. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) IARRAY(N), an array to be permuted. +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + integer ( kind = 4 ) iarray(n) + integer ( kind = 4 ) ignuin + integer ( kind = 4 ) itmp + integer ( kind = 4 ) iwhich + + do i = 1, n + iwhich = ignuin ( i, n ) + itmp = iarray(iwhich) + iarray(iwhich) = iarray(i) + iarray(i) = itmp + end do + + return +end +function genunf ( low, high ) + +!*****************************************************************************80 +! +!! GENUNF generates a uniform random deviate. +! +! Discussion: +! +! This procedure generates a real deviate uniformly distributed between +! LOW and HIGH. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) LOW, HIGH, the lower and upper bounds. +! +! Output, real ( kind = 4 ) GENUNF, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) genunf + real ( kind = 4 ) high + real ( kind = 4 ) low + real ( kind = 4 ) r4_uniform_01 + + genunf = low + ( high - low ) * r4_uniform_01 ( ) + + return +end +function ignbin ( n, pp ) + +!*****************************************************************************80 +! +!! IGNBIN generates a binomial random deviate. +! +! Discussion: +! +! This procedure generates a single random deviate from a binomial +! distribution whose number of trials is N and whose +! probability of an event in each trial is P. +! +! The previous version of this program relied on the assumption that +! local memory would be preserved between calls. It set up data +! one time to be preserved for use over multiple calls. In the +! interests of portability, this assumption has been removed, and +! the "setup" data is recomputed on every call. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Voratas Kachitvichyanukul, Bruce Schmeiser, +! Binomial Random Variate Generation, +! Communications of the ACM, +! Volume 31, Number 2, February 1988, pages 216-222. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of binomial trials, from which a +! random deviate will be generated. +! 0 < N. +! +! Input, real ( kind = 4 ) PP, the probability of an event in each trial of +! the binomial distribution from which a random deviate is to be generated. +! 0.0 < PP < 1.0. +! +! Output, integer ( kind = 4 ) IGNBIN, a random deviate from the +! distribution. +! + implicit none + + real ( kind = 4 ) al + real ( kind = 4 ) alv + real ( kind = 4 ) amaxp + real ( kind = 4 ) c + real ( kind = 4 ) f + real ( kind = 4 ) f1 + real ( kind = 4 ) f2 + real ( kind = 4 ) ffm + real ( kind = 4 ) fm + real ( kind = 4 ) g + integer ( kind = 4 ) i + integer ( kind = 4 ) ignbin + integer ( kind = 4 ) ix + integer ( kind = 4 ) ix1 + integer ( kind = 4 ) k + integer ( kind = 4 ) m + integer ( kind = 4 ) mp + real ( kind = 4 ) pp + integer ( kind = 4 ) n + real ( kind = 4 ) p + real ( kind = 4 ) p1 + real ( kind = 4 ) p2 + real ( kind = 4 ) p3 + real ( kind = 4 ) p4 + real ( kind = 4 ) q + real ( kind = 4 ) qn + real ( kind = 4 ) r + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) t + real ( kind = 4 ) u + real ( kind = 4 ) v + real ( kind = 4 ) w + real ( kind = 4 ) w2 + real ( kind = 4 ) x + real ( kind = 4 ) x1 + real ( kind = 4 ) x2 + real ( kind = 4 ) xl + real ( kind = 4 ) xll + real ( kind = 4 ) xlr + real ( kind = 4 ) xm + real ( kind = 4 ) xnp + real ( kind = 4 ) xnpq + real ( kind = 4 ) xr + real ( kind = 4 ) ynorm + real ( kind = 4 ) z + real ( kind = 4 ) z2 + + if ( pp <= 0.0E+00 .or. 1.0E+00 <= pp ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNBIN - Fatal error!' + write ( *, '(a)' ) ' PP is out of range.' + stop + end if + + p = min ( pp, 1.0E+00 - pp ) + q = 1.0E+00 - p + xnp = real ( n, kind = 4 ) * p + + if ( xnp < 30.0E+00 ) then + + qn = q ** n + r = p / q + g = r * real ( n + 1, kind = 4 ) + + do + + ix = 0 + f = qn + u = r4_uniform_01 ( ) + + do + + if ( u < f ) then + if ( 0.5E+00 < pp ) then + ix = n - ix + end if + ignbin = ix + return + end if + + if ( 110 < ix ) then + exit + end if + + u = u - f + ix = ix + 1 + f = f * ( g / real ( ix, kind = 4 ) - r ) + + end do + + end do + + end if + + ffm = xnp + p + m = ffm + fm = m + xnpq = xnp * q + p1 = int ( 2.195E+00 * sqrt ( xnpq ) - 4.6E+00 * q ) + 0.5E+00 + xm = fm + 0.5E+00 + xl = xm - p1 + xr = xm + p1 + c = 0.134E+00 + 20.5E+00 / ( 15.3E+00 + fm ) + al = ( ffm - xl ) / ( ffm - xl * p ) + xll = al * ( 1.0E+00 + 0.5E+00 * al ) + al = ( xr - ffm ) / ( xr * q ) + xlr = al * ( 1.0E+00 + 0.5E+00 * al ) + p2 = p1 * ( 1.0E+00 + c + c ) + p3 = p2 + c / xll + p4 = p3 + c / xlr +! +! Generate a variate. +! + do + + u = r4_uniform_01 ( ) * p4 + v = r4_uniform_01 ( ) +! +! Triangle +! + if ( u < p1 ) then + ix = xm - p1 * v + u + if ( 0.5E+00 < pp ) then + ix = n - ix + end if + ignbin = ix + return + end if +! +! Parallelogram +! + if ( u <= p2 ) then + + x = xl + ( u - p1 ) / c + v = v * c + 1.0E+00 - abs ( xm - x ) / p1 + + if ( v <= 0.0E+00 .or. 1.0E+00 < v ) then + cycle + end if + + ix = x + + else if ( u <= p3 ) then + + ix = xl + log ( v ) / xll + if ( ix < 0 ) then + cycle + end if + v = v * ( u - p2 ) * xll + + else + + ix = xr - log ( v ) / xlr + if ( n < ix ) then + cycle + end if + v = v * ( u - p3 ) * xlr + + end if + + k = abs ( ix - m ) + + if ( k <= 20 .or. xnpq / 2.0 - 1.0 <= k ) then + + f = 1.0E+00 + r = p / q + g = ( n + 1 ) * r + + if ( m < ix ) then + mp = m + 1 + do i = m + 1, ix + f = f * ( g / i - r ) + end do + else if ( ix < m ) then + ix1 = ix + 1 + do i = ix + 1, m + f = f / ( g / real ( i, kind = 4 ) - r ) + end do + end if + + if ( v <= f ) then + if ( 0.5E+00 < pp ) then + ix = n - ix + end if + ignbin = ix + return + end if + + else + + amaxp = ( k / xnpq ) * ( ( k * ( k / 3.0E+00 & + + 0.625E+00 ) + 0.1666666666666E+00 ) / xnpq + 0.5E+00 ) + ynorm = - real ( k * k, kind = 4 ) / ( 2.0E+00 * xnpq ) + alv = log ( v ) + + if ( alv < ynorm - amaxp ) then + if ( 0.5E+00 < pp ) then + ix = n - ix + end if + ignbin = ix + return + end if + + if ( ynorm + amaxp < alv ) then + cycle + end if + + x1 = real ( ix + 1, kind = 4 ) + f1 = fm + 1.0E+00 + z = real ( n + 1, kind = 4 ) - fm + w = real ( n - ix + 1, kind = 4 ) + z2 = z * z + x2 = x1 * x1 + f2 = f1 * f1 + w2 = w * w + + t = xm * log ( f1 / x1 ) + ( n - m + 0.5E+00 ) * log ( z / w ) & + + real ( ix - m, kind = 4 ) * log ( w * p / ( x1 * q ) ) & + + ( 13860.0E+00 - ( 462.0E+00 - ( 132.0E+00 - ( 99.0E+00 - 140.0E+00 & + / f2 ) / f2 ) / f2 ) / f2 ) / f1 / 166320.0E+00 & + + ( 13860.0E+00 - ( 462.0E+00 - ( 132.0E+00 - ( 99.0E+00 - 140.0E+00 & + / z2 ) / z2 ) / z2 ) / z2 ) / z / 166320.0E+00 & + + ( 13860.0E+00 - ( 462.0E+00 - ( 132.0E+00 - ( 99.0E+00 - 140.0E+00 & + / x2 ) / x2 ) / x2 ) / x2 ) / x1 / 166320.0E+00 & + + ( 13860.0E+00 - ( 462.0E+00 - ( 132.0E+00 - ( 99.0E+00 - 140.0E+00 & + / w2 ) / w2 ) / w2 ) / w2 ) / w / 166320.0E+00 + + if ( alv <= t ) then + if ( 0.5E+00 < pp ) then + ix = n - ix + end if + ignbin = ix + return + end if + + end if + + end do + + return +end +function ignnbn ( n, p ) + +!*****************************************************************************80 +! +!! IGNNBN generates a negative binomial random deviate. +! +! Discussion: +! +! This procedure generates a single random deviate from a negative binomial +! distribution. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Luc Devroye, +! Non-Uniform Random Variate Generation, +! Springer, 1986, +! ISBN: 0387963057, +! LC: QA274.D48. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the required number of events. +! 0 <= N. +! +! Input, real ( kind = 4 ) P, the probability of an event during a +! Bernoulli trial. 0.0 < P < 1.0. +! +! Output, integer ( kind = 4 ) IGNNBN, a random deviate from +! the distribution. +! + implicit none + + real ( kind = 4 ) a + real ( kind = 4 ) gengam + integer ( kind = 4 ) ignnbn + integer ( kind = 4 ) ignpoi + integer ( kind = 4 ) n + real ( kind = 4 ) p + real ( kind = 4 ) r + real ( kind = 4 ) y + + if ( n < 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNNBN - Fatal error!' + write ( *, '(a)' ) ' N < 0.' + stop + end if + + if ( p <= 0.0E+00 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNNBN - Fatal error!' + write ( *, '(a)' ) ' P <= 0.0' + stop + end if + + if ( 1.0E+00 <= p ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNNBN - Fatal error!' + write ( *, '(a)' ) ' 1.0 <= P' + stop + end if +! +! Generate Y, a random gamma (n,(1-p)/p) variable. +! + r = real ( n ) + a = p / ( 1.0E+00 - p ) + y = gengam ( a, r ) +! +! Generate a random Poisson ( y ) variable. +! + ignnbn = ignpoi ( y ) + + return +end +function ignpoi ( mu ) + +!*****************************************************************************80 +! +!! IGNPOI generates a Poisson random deviate. +! +! Discussion: +! +! This procedure generates a single random deviate from a Poisson +! distribution with given mean. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 April 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Computer Generation of Poisson Deviates +! From Modified Normal Distributions, +! ACM Transactions on Mathematical Software, +! Volume 8, Number 2, June 1982, pages 163-179. +! +! Parameters: +! +! Input, real ( kind = 4 ) MU, the mean of the Poisson distribution +! from which a random deviate is to be generated. +! +! Output, integer ( kind = 4 ) IGNPOI, a random deviate from +! the distribution. +! + implicit none + + real ( kind = 4 ), parameter :: a0 = -0.5E+00 + real ( kind = 4 ), parameter :: a1 = 0.3333333E+00 + real ( kind = 4 ), parameter :: a2 = -0.2500068E+00 + real ( kind = 4 ), parameter :: a3 = 0.2000118E+00 + real ( kind = 4 ), parameter :: a4 = -0.1661269E+00 + real ( kind = 4 ), parameter :: a5 = 0.1421878E+00 + real ( kind = 4 ), parameter :: a6 = -0.1384794E+00 + real ( kind = 4 ), parameter :: a7 = 0.1250060E+00 + real ( kind = 4 ) b1 + real ( kind = 4 ) b2 + real ( kind = 4 ) c + real ( kind = 4 ) c0 + real ( kind = 4 ) c1 + real ( kind = 4 ) c2 + real ( kind = 4 ) c3 + real ( kind = 4 ) d + real ( kind = 4 ) del + real ( kind = 4 ) difmuk + real ( kind = 4 ) e + real ( kind = 4 ) fact(10) + real ( kind = 4 ) fk + real ( kind = 4 ) fx + real ( kind = 4 ) fy + real ( kind = 4 ) g + integer ( kind = 4 ) ignpoi + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) kflag + integer ( kind = 4 ) l + integer ( kind = 4 ) m + real ( kind = 4 ) mu + real ( kind = 4 ) muold + real ( kind = 4 ) muprev + real ( kind = 4 ) omega + real ( kind = 4 ) p + real ( kind = 4 ) p0 + real ( kind = 4 ) px + real ( kind = 4 ) py + real ( kind = 4 ) q + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) s + real ( kind = 4 ) sexpo + real ( kind = 4 ) snorm + real ( kind = 4 ) t + real ( kind = 4 ) u + real ( kind = 4 ) v + real ( kind = 4 ) x + real ( kind = 4 ) xx + + save fact + + data fact / 1.0E+00, 1.0E+00, 2.0E+00, 6.0E+00, 24.0E+00, & + 120.0E+00, 720.0E+00, 5040.0E+00, 40320.0E+00, 362880.0E+00 / +! +! Start new table and calculate P0. +! + if ( mu < 10.0E+00 ) then + + m = max ( 1, int ( mu ) ) + p = exp ( - mu ) + q = p + p0 = p +! +! Uniform sample for inversion method. +! + do + + u = r4_uniform_01 ( ) + ignpoi = 0 + + if ( u <= p0 ) then + return + end if +! +! Creation of new Poisson probabilities. +! + do k = 1, 35 + p = p * mu / real ( k ) + q = q + p + if ( u <= q ) then + ignpoi = k + return + end if + end do + + end do + + else + + s = sqrt ( mu ) + d = 6.0E+00 * mu * mu + l = int ( mu - 1.1484E+00 ) +! +! Normal sample. +! + g = mu + s * snorm ( ) + + if ( 0.0E+00 <= g ) then + + ignpoi = int ( g ) +! +! Immediate acceptance if large enough. +! + if ( l <= ignpoi ) then + return + end if +! +! Squeeze acceptance. +! + fk = real ( ignpoi ) + difmuk = mu - fk + u = r4_uniform_01 ( ) + + if ( difmuk * difmuk * difmuk <= d * u ) then + return + end if + + end if +! +! Preparation for steps P and Q. +! + omega = 0.3989423E+00 / s + b1 = 0.04166667E+00 / mu + b2 = 0.3E+00 * b1 * b1 + c3 = 0.1428571E+00 * b1 * b2 + c2 = b2 - 15.0E+00 * c3 + c1 = b1 - 6.0E+00 * b2 + 45.0E+00 * c3 + c0 = 1.0E+00 - b1 + 3.0E+00 * b2 - 15.0E+00 * c3 + c = 0.1069E+00 / mu + + if ( 0.0E+00 <= g ) then + + kflag = 0 + + if ( ignpoi < 10 ) then + + px = -mu + py = mu ** ignpoi / fact(ignpoi+1) + + else + + del = 0.8333333E-01 / fk + del = del - 4.8E+00 * del * del * del + v = difmuk / fk + + if ( 0.25E+00 < abs ( v ) ) then + px = fk * log ( 1.0E+00 + v ) - difmuk - del + else + px = fk * v * v * ((((((( a7 & + * v + a6 ) & + * v + a5 ) & + * v + a4 ) & + * v + a3 ) & + * v + a2 ) & + * v + a1 ) & + * v + a0 ) - del + end if + + py = 0.3989423E+00 / sqrt ( fk ) + + end if + + x = ( 0.5E+00 - difmuk ) / s + xx = x * x + fx = -0.5E+00 * xx + fy = omega * ((( c3 * xx + c2 ) * xx + c1 ) * xx + c0 ) + + if ( kflag <= 0 ) then + + if ( fy - u * fy <= py * exp ( px - fx ) ) then + return + end if + + else + + if ( c * abs ( u ) <= py * exp ( px + e ) - fy * exp ( fx + e ) ) then + return + end if + + end if + + end if +! +! Exponential sample. +! + do + + e = sexpo ( ) + u = 2.0E+00 * r4_uniform_01 ( ) - 1.0E+00 + if ( u < 0.0E+00 ) then + t = 1.8E+00 - abs ( e ) + else + t = 1.8E+00 + abs ( e ) + end if + + if ( t <= -0.6744E+00 ) then + cycle + end if + + ignpoi = int ( mu + s * t ) + fk = real ( ignpoi ) + difmuk = mu - fk + + kflag = 1 +! +! Calculation of PX, PY, FX, FY. +! + if ( ignpoi < 10 ) then + + px = -mu + py = mu ** ignpoi / fact(ignpoi+1) + + else + + del = 0.8333333E-01 / fk + del = del - 4.8E+00 * del * del * del + v = difmuk / fk + + if ( 0.25E+00 < abs ( v ) ) then + px = fk * log ( 1.0E+00 + v ) - difmuk - del + else + px = fk * v * v * ((((((( a7 & + * v + a6 ) & + * v + a5 ) & + * v + a4 ) & + * v + a3 ) & + * v + a2 ) & + * v + a1 ) & + * v + a0 ) - del + end if + + py = 0.3989423E+00 / sqrt ( fk ) + + end if + + x = ( 0.5E+00 - difmuk ) / s + xx = x * x + fx = -0.5E+00 * xx + fy = omega * ((( c3 * xx + c2 ) * xx + c1 ) * xx + c0 ) + + if ( kflag <= 0 ) then + + if ( fy - u * fy <= py * exp ( px - fx ) ) then + return + end if + + else + + if ( c * abs ( u ) <= py * exp ( px + e ) - fy * exp ( fx + e ) ) then + return + end if + + end if + + end do + + end if + +end +function ignuin ( low, high ) + +!*****************************************************************************80 +! +!! IGNUIN generates a random integer in a given range. +! +! Discussion: +! +! Each deviate K satisfies LOW <= K <= HIGH. +! +! If (HIGH-LOW) > 2,147,483,561, this procedure prints an error message +! and stops the program. +! +! IGNLGI generates integer ( kind = 4 )s between 1 and 2147483562. +! +! MAXNUM is 1 less than the maximum generatable value. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, integer ( kind = 4 ) LOW, HIGH, the lower and upper bounds. +! +! Output, integer ( kind = 4 ) IGNUIN, a random deviate from +! the distribution. +! + implicit none + + integer ( kind = 4 ) err + integer ( kind = 4 ) high + integer ( kind = 4 ) i4_uniform + integer ( kind = 4 ) ign + integer ( kind = 4 ) ignuin + integer ( kind = 4 ) low + integer ( kind = 4 ) maxnow + integer ( kind = 4 ) maxnum + parameter ( maxnum = 2147483561 ) + integer ( kind = 4 ) ranp1 + integer ( kind = 4 ) width + + if ( high < low ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNUIN - Fatal error!' + write ( *, '(a)' ) ' HIGH < LOW.' + stop + end if + + width = high - low + + if ( maxnum < width ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'IGNUIN - Fatal error!' + write ( *, '(a)' ) ' Range HIGH-LOW is too large.' + stop + end if + + if ( low == high ) then + ignuin = low + return + end if + + ranp1 = width + 1 + maxnow = ( maxnum / ranp1 ) * ranp1 + + do + + ign = i4_uniform ( ) - 1 + + if ( ign <= maxnow ) then + exit + end if + + end do + + ignuin = low + mod ( ign, ranp1 ) + + return +end +function lennob ( s ) + +!*****************************************************************************80 +! +!! LENNOB counts the length of a string, ignoring trailing blanks. +! +! Discussion: +! +! This procedure returns the length of a string up to and including +! the last non-blank character. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, character * ( * ) S, the string. +! +! Output, integer ( kind = 4 ) LENNOB, the length of the string to the last +! nonblank. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) lennob + character * ( * ) s + integer ( kind = 4 ) s_max + + s_max = len ( s ) + + do i = s_max, 1, -1 + if ( s(i:i) /= ' ' ) then + lennob = i + return + end if + end do + + lennob = 0 + + return +end +subroutine phrtsd ( phrase, seed1, seed2 ) + +!*****************************************************************************80 +! +!! PHRTST converts a phrase to a pair of random number generator seeds. +! +! Discussion: +! +! This procedure uses a character string to generate two seeds for the RGN +! random number generator. +! +! Trailing blanks are eliminated before the seeds are generated. +! +! Generated seed values will fall in the range 1 to 2^30 = 1,073,741,824. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, character * ( * ) PHRASE, a phrase to be used for the +! random number generation. +! +! Output, integer ( kind = 4 ) SEED1, SEED2, the two seeds for the +! random number generator, based on PHRASE. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) ichr + integer ( kind = 4 ) j + integer ( kind = 4 ) lennob + integer ( kind = 4 ) lphr + character * ( * ) phrase + integer ( kind = 4 ) seed1 + integer ( kind = 4 ) seed2 + integer ( kind = 4 ) shift(0:4) + character * ( 86 ) table + parameter ( table = & + 'abcdefghijklmnopqrstuvwxyz'// & + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'// & + '0123456789'// & + '!@#$%^&*()_+[];:''"<>?,./' ) + integer ( kind = 4 ) twop30 + parameter ( twop30 = 1073741824 ) + integer ( kind = 4 ) values(5) + + save shift + + data shift / 1, 64, 4096, 262144, 16777216 / + + seed1 = 1234567890 + seed2 = 123456789 + + lphr = lennob ( phrase ) + + do i = 1, lphr + + ichr = index ( table, phrase(i:i) ) +! +! If the character does not occur, ICHR is returned as 0. +! + ichr = mod ( ichr, 64 ) + + if ( ichr == 0 ) then + ichr = 63 + end if + + do j = 1, 5 + values(j) = ichr - j + if ( values(j) < 1 ) then + values(j) = values(j) + 63 + end if + end do + + do j = 1, 5 + seed1 = mod ( seed1 + shift(j-1) * values(j), twop30 ) + seed2 = mod ( seed2 + shift(j-1) * values(6-j), twop30 ) + end do + + end do + + return +end +subroutine prcomp ( maxobs, p, mean, xcovar, answer ) + +!*****************************************************************************80 +! +!! PRCOMP prints covariance information. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, the number of variables. +! +! Input, real ( kind = 4 ) MEAN(P), the mean for each column. +! +! Input, real ( kind = 4 ) XCOVAR(P,P), the variance/covariance matrix. +! +! Input, real ( kind = 4 ) ANSWER(MAXOBS,P), the observed values. +! + implicit none + + integer ( kind = 4 ) p + integer ( kind = 4 ) maxobs + + real ( kind = 4 ) answer(maxobs,p) + real ( kind = 4 ) dum1 + real ( kind = 4 ) dum2 + integer ( kind = 4 ) i + integer ( kind = 4 ) j + real ( kind = 4 ) mean(p) + real ( kind = 4 ) r4vec_covar + real ( kind = 4 ) rcovar(p,p) + real ( kind = 4 ) rmean(p) + real ( kind = 4 ) rvar(p) + real ( kind = 4 ) xcovar(p,p) + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'PRCOMP:' + write ( *, '(a)' ) ' Print and compare covariance information' + write ( *, '(a)' ) ' ' + + do j = 1, p + call stats ( answer(1,j), maxobs, rmean(j), rvar(j), & + dum1, dum2 ) + write ( *, '(a,i4)' ) ' Variable Number ', j + write ( *, '(a,g14.6,a,g14.6)' ) & + ' Mean ', mean(j), ' Generated ', rmean(j) + write ( *, '(a,g14.6,a,g14.6)' ) & + ' Variance ', xcovar(j,j), ' Generated ', rvar(j) + end do + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' Covariances:' + write ( *, '(a)' ) ' ' + + do i = 1, p + do j = 1, i - 1 + write ( *, '(a,i4,a,i4)' ) ' I = ', i, ' J = ', j + rcovar(i,j) = r4vec_covar ( maxobs, answer(1,i), answer(1,j) ) + write ( *, '(a,g14.6,a,g14.6)' ) & + ' Covariance ', xcovar(i,j), ' Generated ', rcovar(i,j) + end do + end do + + return +end +function r4_exponential_sample ( lambda ) + +!*****************************************************************************80 +! +!! R4_EXPONENTIAL_SAMPLE samples the exponential PDF. +! +! Discussion: +! +! Note that the parameter LAMBDA is a multiplier. In some formulations, +! it is used as a divisor instead. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 April 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 4 ) LAMBDA, the parameter of the PDF. +! +! Output, real ( kind = 4 ) R4_EXPONENTIAL_SAMPLE, a sample of the PDF. +! + implicit none + + real ( kind = 4 ) lambda + real ( kind = 4 ) r + real ( kind = 4 ) r4_exponential_sample + real ( kind = 4 ) r4_uniform_01 + + r = r4_uniform_01 ( ) + + r4_exponential_sample = - log ( r ) * lambda + + return +end +function r4vec_covar ( n, x, y ) + +!*****************************************************************************80 +! +!! R4VEC_COVAR computes the covariance of two vectors. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 April 2013 +! +! Author: +! +! John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) X(N), Y(N), the two vectors. +! +! Input, integer ( kind = 4 ) N, the dimension of the two vectors. +! +! Output, real ( kind = 4 ) R4VEC_COVAR, the covariance of the vectors. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + real ( kind = 4 ) r4vec_covar + real ( kind = 4 ) value + real ( kind = 4 ) x(n) + real ( kind = 4 ) x_average + real ( kind = 4 ) y(n) + real ( kind = 4 ) y_average + + x_average = sum ( x(1:n) ) / real ( n, kind = 4 ) + y_average = sum ( y(1:n) ) / real ( n, kind = 4 ) + + value = 0.0E+00 + do i = 1, n + value = value + ( x(i) - x_average ) * ( y(i) - y_average ) + end do + + r4vec_covar = value / real ( n - 1, kind = 4 ) + + return +end +function r8_exponential_sample ( lambda ) + +!*****************************************************************************80 +! +!! R8_EXPONENTIAL_SAMPLE samples the exponential PDF. +! +! Discussion: +! +! Note that the parameter LAMBDA is a multiplier. In some formulations, +! it is used as a divisor instead. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 April 2013 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) LAMBDA, the parameter of the PDF. +! +! Output, real ( kind = 8 ) R8_EXPONENTIAL_SAMPLE, a sample of the PDF. +! + implicit none + + real ( kind = 8 ) lambda + real ( kind = 8 ) r + real ( kind = 8 ) r8_exponential_sample + real ( kind = 8 ) r8_uniform_01 + + r = r8_uniform_01 ( ) + + r8_exponential_sample = - log ( r ) * lambda + + return +end +function r8vec_covar ( n, x, y ) + +!*****************************************************************************80 +! +!! R8VEC_COVAR computes the covariance of two vectors. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 April 2013 +! +! Author: +! +! John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 8 ) X(N), Y(N), the two vectors. +! +! Input, integer ( kind = 4 ) N, the dimension of the two vectors. +! +! Output, real ( kind = 8 ) R4VEC_COVAR, the covariance of the vectors. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + real ( kind = 8 ) r8vec_covar + real ( kind = 8 ) value + real ( kind = 8 ) x(n) + real ( kind = 8 ) x_average + real ( kind = 8 ) y(n) + real ( kind = 8 ) y_average + + x_average = sum ( x(1:n) ) / real ( n, kind = 8 ) + y_average = sum ( y(1:n) ) / real ( n, kind = 8 ) + + value = 0.0D+00 + do i = 1, n + value = value + ( x(i) - x_average ) * ( y(i) - y_average ) + end do + + r8vec_covar = value / real ( n - 1, kind = 8 ) + + return +end +function sdot ( n, sx, incx, sy, incy ) + +!*****************************************************************************80 +! +!! SDOT forms the dot product of two vectors. +! +! Discussion: +! +! This routine uses single precision real ( kind = 4 ) arithmetic. +! +! This routine uses unrolled loops for increments equal to one. +! +! Modified: +! +! 07 July 2007 +! +! Author: +! +! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh +! +! Reference: +! +! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, +! LINPACK User's Guide, +! SIAM, 1979, +! ISBN13: 978-0-898711-72-1, +! LC: QA214.L56. +! +! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, +! Basic Linear Algebra Subprograms for FORTRAN usage, +! ACM Transactions on Mathematical Software, +! Volume 5, Number 3, pages 308-323, 1979. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the vectors. +! +! Input, real ( kind = 4 ) X(*), one of the vectors to be multiplied. +! +! Input, integer ( kind = 4 ) INCX, the increment between successive +! entries of X. +! +! Input, real ( kind = 4 ) Y(*), one of the vectors to be multiplied. +! +! Input, integer ( kind = 4 ) INCY, the increment between successive +! elements of Y. +! +! Output, real ( kind = 4 ) SDOT, the dot product of X and Y. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) incx + integer ( kind = 4 ) incy + integer ( kind = 4 ) ix + integer ( kind = 4 ) iy + integer ( kind = 4 ) m + integer ( kind = 4 ) n + real ( kind = 4 ) sdot + real ( kind = 4 ) stemp + real ( kind = 4 ) sx(*) + real ( kind = 4 ) sy(*) + + sdot = 0.0E+00 + + if ( n <= 0 ) then + return + end if + + stemp = 0.0E+00 +! +! Code for unequal increments or equal increments not equal to 1. +! + if ( incx /= 1 .or. incy /= 1 ) then + + if ( incx < 0 ) then + ix = ( - n + 1 ) * incx + 1 + else + ix = 1 + end if + + if ( incy < 0 ) then + iy = ( - n + 1 ) * incy + 1 + else + iy = 1 + end if + + do i = 1, n + stemp = stemp + sx(ix) * sy(iy) + ix = ix + incx + iy = iy + incy + end do +! +! Code for both increments equal to 1. +! + else + + m = mod ( n, 5 ) + + do i = 1, m + stemp = stemp + sx(i) * sy(i) + end do + + do i = m + 1, n, 5 + stemp = stemp & + + sx(i) * sy(i) & + + sx(i + 1) * sy(i + 1) & + + sx(i + 2) * sy(i + 2) & + + sx(i + 3) * sy(i + 3) & + + sx(i + 4) * sy(i + 4) + end do + + end if + + sdot = stemp + + return +end +subroutine setcov ( p, var, corr, covar ) + +!*****************************************************************************80 +! +!! SETCOV sets a covariance matrix from variance and common correlation. +! +! Discussion: +! +! This procedure sets the covariance matrix from the variance and +! common correlation. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, integer ( kind = 4 ) P, the number of variables. +! +! Input, real ( kind = 4 ) VAR(P), the variances. +! +! Input, real ( kind = 4 ) CORR, the common correlaton. +! +! Output, real ( kind = 4 ) COVAR(P,P), the covariance matrix. +! + implicit none + + integer ( kind = 4 ) p + + real ( kind = 4 ) corr + real ( kind = 4 ) covar(p,p) + integer ( kind = 4 ) i + integer ( kind = 4 ) j + real ( kind = 4 ) var(p) + + do i = 1, p + do j = 1, p + if ( i == j ) then + covar(i,j) = var(i) + else + covar(i,j) = corr * sqrt ( var(i) * var(j) ) + end if + end do + end do + + return +end +subroutine setgmn ( meanv, covm, p, parm ) + +!*****************************************************************************80 +! +!! SETGMN sets data for the generation of multivariate normal deviates. +! +! Discussion: +! +! This procedure places P, MEANV, and the Cholesky factorization of +! COVM in GENMN. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) MEANV(P), the means of the multivariate +! normal distribution. +! +! Input/output, real ( kind = 4 ) COVM(P,P). On input, the covariance +! matrix of the multivariate distribution. On output, the information +! in COVM has been overwritten. +! +! Input, integer ( kind = 4 ) P, the number of dimensions. +! +! Output, real ( kind = 4 ) PARM(P*(P+3)/2+1), parameters needed to generate +! multivariate normal deviates. +! + implicit none + + integer ( kind = 4 ) p + + real ( kind = 4 ) covm(p,p) + integer ( kind = 4 ) i + integer ( kind = 4 ) icount + integer ( kind = 4 ) info + integer ( kind = 4 ) j + real ( kind = 4 ) meanv(p) + real ( kind = 4 ) parm(p*(p+3)/2+1) + + if ( p <= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'SETGMN - Fatal error!' + write ( *, '(a)' ) ' P was not positive.' + stop + end if +! +! Store P. +! + parm(1) = p +! +! Store MEANV. +! + do i = 2, p + 1 + parm(i) = meanv(i-1) + end do +! +! Compute the Cholesky decomposition. +! + call spofa ( covm, p, p, info ) + + if ( info /= 0) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'SETGMN - Fatal error!' + write ( *, '(a)' ) ' SPOFA finds COVM not positive definite.' + stop + end if +! +! Store the upper half of the Cholesky factor. +! + icount = p + 1 + + do i = 1, p + do j = i, p + icount = icount + 1 + parm(icount) = covm(i,j) + end do + end do + + return +end +function sexpo ( ) + +!*****************************************************************************80 +! +!! SEXPO samples the standard exponential distribution. +! +! Discussion: +! +! This procedure corresponds to algorithm SA in the reference. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Computer Methods for Sampling From the +! Exponential and Normal Distributions, +! Communications of the ACM, +! Volume 15, Number 10, October 1972, pages 873-882. +! +! Parameters: +! +! Output, real ( kind = 4 ) SEXPO, a random deviate from the standard +! exponential distribution. +! + implicit none + + real ( kind = 4 ) a + integer ( kind = 4 ) i + real ( kind = 4 ) q(8) + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) sexpo + real ( kind = 4 ) u + real ( kind = 4 ) umin + real ( kind = 4 ) ustar + + save q + + data q / & + 0.6931472E+00, & + 0.9333737E+00, & + 0.9888778E+00, & + 0.9984959E+00, & + 0.9998293E+00, & + 0.9999833E+00, & + 0.9999986E+00, & + 0.9999999E+00 / + + a = 0.0E+00 + u = r4_uniform_01 ( ) + + do + + u = u + u + + if ( 1.0E+00 < u ) then + exit + end if + + a = a + q(1) + + end do + + u = u - 1.0E+00 + + if ( u <= q(1) ) then + sexpo = a + u + return + end if + + i = 1 + ustar = r4_uniform_01 ( ) + umin = ustar + + do + + ustar = r4_uniform_01 ( ) + umin = min ( umin, ustar ) + i = i + 1 + + if ( u <= q(i) ) then + exit + end if + + end do + + sexpo = a + umin * q(1) + + return +end +function sgamma ( a ) + +!*****************************************************************************80 +! +!! SGAMMA samples the standard Gamma distribution. +! +! Discussion: +! +! This procedure corresponds to algorithm GD in the reference. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 April 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Generating Gamma Variates by a Modified Rejection Technique, +! Communications of the ACM, +! Volume 25, Number 1, January 1982, pages 47-54. +! +! Parameters: +! +! Input, real ( kind = 4 ) A, the parameter of the standard gamma +! distribution. 0.0 < A < 1.0. +! +! Output, real ( kind = 4 ) SGAMMA, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) a + real ( kind = 4 ), parameter :: a1 = 0.3333333E+00 + real ( kind = 4 ), parameter :: a2 = -0.2500030E+00 + real ( kind = 4 ), parameter :: a3 = 0.2000062E+00 + real ( kind = 4 ), parameter :: a4 = -0.1662921E+00 + real ( kind = 4 ), parameter :: a5 = 0.1423657E+00 + real ( kind = 4 ), parameter :: a6 = -0.1367177E+00 + real ( kind = 4 ), parameter :: a7 = 0.1233795E+00 + real ( kind = 4 ) b + real ( kind = 4 ) c + real ( kind = 4 ) d + real ( kind = 4 ) e + real ( kind = 4 ), parameter :: e1 = 1.0E+00 + real ( kind = 4 ), parameter :: e2 = 0.4999897E+00 + real ( kind = 4 ), parameter :: e3 = 0.1668290E+00 + real ( kind = 4 ), parameter :: e4 = 0.0407753E+00 + real ( kind = 4 ), parameter :: e5 = 0.0102930E+00 + real ( kind = 4 ) p + real ( kind = 4 ) q + real ( kind = 4 ) q0 + real ( kind = 4 ), parameter :: q1 = 0.04166669E+00 + real ( kind = 4 ), parameter :: q2 = 0.02083148E+00 + real ( kind = 4 ), parameter :: q3 = 0.00801191E+00 + real ( kind = 4 ), parameter :: q4 = 0.00144121E+00 + real ( kind = 4 ), parameter :: q5 = -0.00007388E+00 + real ( kind = 4 ), parameter :: q6 = 0.00024511E+00 + real ( kind = 4 ), parameter :: q7 = 0.00024240E+00 + real ( kind = 4 ) r + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) s + real ( kind = 4 ) s2 + real ( kind = 4 ) sexpo + real ( kind = 4 ) si + real ( kind = 4 ) sgamma + real ( kind = 4 ) snorm + real ( kind = 4 ), parameter :: sqrt32 = 5.656854E+00 + real ( kind = 4 ) t + real ( kind = 4 ) u + real ( kind = 4 ) v + real ( kind = 4 ) w + real ( kind = 4 ) x + + if ( 1.0E+00 <= a ) then + + s2 = a - 0.5E+00 + s = sqrt ( s2 ) + d = sqrt32 - 12.0E+00 * s +! +! Immediate acceptance. +! + t = snorm ( ) + x = s + 0.5E+00 * t + sgamma = x * x + + if ( 0.0E+00 <= t ) then + return + end if +! +! Squeeze acceptance. +! + u = r4_uniform_01 ( ) + if ( d * u <= t * t * t ) then + return + end if + + r = 1.0E+00 / a + q0 = (((((( q7 & + * r + q6 ) & + * r + q5 ) & + * r + q4 ) & + * r + q3 ) & + * r + q2 ) & + * r + q1 ) & + * r +! +! Approximation depending on size of parameter A. +! + if ( 13.022E+00 < a ) then + b = 1.77E+00 + si = 0.75E+00 + c = 0.1515E+00 / s + else if ( 3.686E+00 < a ) then + b = 1.654E+00 + 0.0076E+00 * s2 + si = 1.68E+00 / s + 0.275E+00 + c = 0.062E+00 / s + 0.024E+00 + else + b = 0.463E+00 + s + 0.178E+00 * s2 + si = 1.235E+00 + c = 0.195E+00 / s - 0.079E+00 + 0.16E+00 * s + end if +! +! Quotient test. +! + if ( 0.0E+00 < x ) then + + v = 0.5E+00 * t / s + + if ( 0.25E+00 < abs ( v ) ) then + q = q0 - s * t + 0.25E+00 * t * t + 2.0E+00 * s2 * log ( 1.0E+00 + v ) + else + q = q0 + 0.5E+00 * t * t * (((((( a7 & + * v + a6 ) & + * v + a5 ) & + * v + a4 ) & + * v + a3 ) & + * v + a2 ) & + * v + a1 ) & + * v + end if + + if ( log ( 1.0E+00 - u ) <= q ) then + return + end if + + end if + + do + + e = sexpo ( ) + u = 2.0E+00 * r4_uniform_01 ( ) - 1.0E+00 + + if ( 0.0E+00 <= u ) then + t = b + abs ( si * e ) + else + t = b - abs ( si * e ) + end if +! +! Possible rejection. +! + if ( t < -0.7187449E+00 ) then + cycle + end if +! +! Calculate V and quotient Q. +! + v = 0.5E+00 * t / s + + if ( 0.25E+00 < abs ( v ) ) then + q = q0 - s * t + 0.25E+00 * t * t + 2.0E+00 * s2 * log ( 1.0E+00 + v ) + else + q = q0 + 0.5E+00 * t * t * (((((( a7 & + * v + a6 ) & + * v + a5 ) & + * v + a4 ) & + * v + a3 ) & + * v + a2 ) & + * v + a1 ) & + * v + end if +! +! Hat acceptance. +! + if ( q <= 0.0E+00 ) then + cycle + end if + + if ( 0.5E+00 < q ) then + w = exp ( q ) - 1.0E+00 + else + w = (((( e5 * q + e4 ) * q + e3 ) * q + e2 ) * q + e1 ) * q + end if +! +! May have to sample again. +! + if ( c * abs ( u ) <= w * exp ( e - 0.5E+00 * t * t ) ) then + exit + end if + + end do + + x = s + 0.5E+00 * t + sgamma = x * x + + return +! +! Method for A < 1. +! + else + + b = 1.0E+00 + 0.3678794E+00 * a + + do + + p = b * r4_uniform_01 ( ) + + if ( p < 1.0E+00 ) then + + sgamma = exp ( log ( p ) / a ) + + if ( sgamma <= sexpo ( ) ) then + return + end if + + cycle + + end if + + sgamma = - log ( ( b - p ) / a ) + + if ( ( 1.0E+00 - a ) * log ( sgamma ) <= sexpo ( ) ) then + exit + end if + + end do + + end if + + return +end +function snorm ( ) + +!*****************************************************************************80 +! +!! SNORM samples the standard normal distribution. +! +! Discussion: +! +! This procedure corresponds to algorithm FL, with M = 5, in the reference. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Joachim Ahrens, Ulrich Dieter, +! Extensions of Forsythe's Method for Random +! Sampling from the Normal Distribution, +! Mathematics of Computation, +! Volume 27, Number 124, October 1973, page 927-937. +! +! Parameters: +! +! Output, real ( kind = 4 ) SNORM, a random deviate from the distribution. +! + implicit none + + real ( kind = 4 ) a(32) + real ( kind = 4 ) aa + real ( kind = 4 ) d(31) + real ( kind = 4 ) h(31) + integer ( kind = 4 ) i + real ( kind = 4 ) r4_uniform_01 + real ( kind = 4 ) s + real ( kind = 4 ) snorm + real ( kind = 4 ) t(31) + real ( kind = 4 ) tt + real ( kind = 4 ) u + real ( kind = 4 ) ustar + real ( kind = 4 ) w + real ( kind = 4 ) y + + save a + save d + save h + save t + + data a / & + 0.0000000E+00, 0.3917609E-01, 0.7841241E-01, 0.1177699E+00, & + 0.1573107E+00, 0.1970991E+00, 0.2372021E+00, 0.2776904E+00, & + 0.3186394E+00, 0.3601299E+00, 0.4022501E+00, 0.4450965E+00, & + 0.4887764E+00, 0.5334097E+00, 0.5791322E+00, 0.6260990E+00, & + 0.6744898E+00, 0.7245144E+00, 0.7764218E+00, 0.8305109E+00, & + 0.8871466E+00, 0.9467818E+00, 1.009990E+00, 1.077516E+00, & + 1.150349E+00, 1.229859E+00, 1.318011E+00, 1.417797E+00, & + 1.534121E+00, 1.675940E+00, 1.862732E+00, 2.153875E+00 / + + data d / & + 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, & + 0.0000000E+00, 0.2636843E+00, 0.2425085E+00, 0.2255674E+00, & + 0.2116342E+00, 0.1999243E+00, 0.1899108E+00, 0.1812252E+00, & + 0.1736014E+00, 0.1668419E+00, 0.1607967E+00, 0.1553497E+00, & + 0.1504094E+00, 0.1459026E+00, 0.1417700E+00, 0.1379632E+00, & + 0.1344418E+00, 0.1311722E+00, 0.1281260E+00, 0.1252791E+00, & + 0.1226109E+00, 0.1201036E+00, 0.1177417E+00, 0.1155119E+00, & + 0.1134023E+00, 0.1114027E+00, 0.1095039E+00 / + + data h / & + 0.3920617E-01, 0.3932705E-01, 0.3950999E-01, 0.3975703E-01, & + 0.4007093E-01, 0.4045533E-01, 0.4091481E-01, 0.4145507E-01, & + 0.4208311E-01, 0.4280748E-01, 0.4363863E-01, 0.4458932E-01, & + 0.4567523E-01, 0.4691571E-01, 0.4833487E-01, 0.4996298E-01, & + 0.5183859E-01, 0.5401138E-01, 0.5654656E-01, 0.5953130E-01, & + 0.6308489E-01, 0.6737503E-01, 0.7264544E-01, 0.7926471E-01, & + 0.8781922E-01, 0.9930398E-01, 0.1155599E+00, 0.1404344E+00, & + 0.1836142E+00, 0.2790016E+00, 0.7010474E+00 / + + data t / & + 0.7673828E-03, 0.2306870E-02, 0.3860618E-02, 0.5438454E-02, & + 0.7050699E-02, 0.8708396E-02, 0.1042357E-01, 0.1220953E-01, & + 0.1408125E-01, 0.1605579E-01, 0.1815290E-01, 0.2039573E-01, & + 0.2281177E-01, 0.2543407E-01, 0.2830296E-01, 0.3146822E-01, & + 0.3499233E-01, 0.3895483E-01, 0.4345878E-01, 0.4864035E-01, & + 0.5468334E-01, 0.6184222E-01, 0.7047983E-01, 0.8113195E-01, & + 0.9462444E-01, 0.1123001E+00, 0.1364980E+00, 0.1716886E+00, & + 0.2276241E+00, 0.3304980E+00, 0.5847031E+00 / + + u = r4_uniform_01 ( ) + if ( u <= 0.5E+00 ) then + s = 0.0E+00 + else + s = 1.0E+00 + end if + u = 2.0E+00 * u - s + u = 32.0E+00 * u + i = int ( u ) + if ( i == 32 ) then + i = 31 + end if +! +! Center +! + if ( i /= 0 ) then + + ustar = u - real ( i ) + aa = a(i) + + do + + if ( t(i) < ustar ) then + + w = ( ustar - t(i) ) * h(i) + + y = aa + w + + if ( s /= 1.0E+00 ) then + snorm = y + else + snorm = -y + end if + + return + + end if + + u = r4_uniform_01 ( ) + w = u * ( a(i+1) - aa ) + tt = ( 0.5E+00 * w + aa ) * w + + do + + if ( tt < ustar ) then + y = aa + w + if ( s /= 1.0E+00 ) then + snorm = y + else + snorm = -y + end if + return + end if + + u = r4_uniform_01 ( ) + + if ( ustar < u ) then + exit + end if + + tt = u + ustar = r4_uniform_01 ( ) + + end do + + ustar = r4_uniform_01 ( ) + + end do +! +! Tail +! + else + + i = 6 + aa = a(32) + + do + + u = u + u + + if ( 1.0E+00 <= u ) then + exit + end if + + aa = aa + d(i) + i = i + 1 + + end do + + u = u - 1.0E+00 + w = u * d(i) + tt = ( 0.5E+00 * w + aa ) * w + + do + + ustar = r4_uniform_01 ( ) + + if ( tt < ustar ) then + y = aa + w + if ( s /= 1.0E+00 ) then + snorm = y + else + snorm = -y + end if + return + end if + + u = r4_uniform_01 ( ) + + if ( u <= ustar ) then + tt = u + else + u = r4_uniform_01 ( ) + w = u * d(i) + tt = ( 0.5E+00 * w + aa ) * w + end if + + end do + + end if + +end +subroutine spofa ( a, lda, n, info ) + +!*****************************************************************************80 +! +!! SPOFA factors a real symmetric positive definite matrix. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 20 March 2013 +! +! Author: +! +! Cleve Moler +! +! Parameters: +! +! Input/output, real ( kind = 4 ) A(LDA,N). On input, the symmetric matrix +! to be factored. Only the diagonal and upper triangle are accessed. +! On output, the strict lower triangle has not been changed. The diagonal +! and upper triangle contain an upper triangular matrix R such that +! A = R' * R. If INFO is nonzero, the factorization was not completed. +! +! Input, integer ( kind = 4 ) LDA, the leading dimension of the array A. +! N <= LDA. +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! +! Output, integer ( kind = 4 ) INFO, error flag. +! 0, no error was detected. +! K, the leading minor of order K is not positive definite. +! + implicit none + + integer ( kind = 4 ) lda + integer ( kind = 4 ) n + + real ( kind = 4 ) a(lda,n) + integer ( kind = 4 ) info + integer ( kind = 4 ) j + integer ( kind = 4 ) jm1 + integer ( kind = 4 ) k + real ( kind = 4 ) s + real ( kind = 4 ) sdot + real ( kind = 4 ) t + + info = 0 + + do j = 1, n + info = j + s = 0.0E+00 + jm1 = j - 1 + do k = 1, jm1 + t = a(k,j) - sdot ( k-1, a(1,k), 1, a(1,j), 1 ) + t = t / a(k,k) + a(k,j) = t + s = s + t * t + end do + s = a(j,j) - s + if ( s <= 0.0E+00 ) then + info = j + return + end if + a(j,j) = sqrt ( s ) + end do + + return +end +subroutine stats ( x, n, av, var, xmin, xmax ) + +!*****************************************************************************80 +! +!! STATS computes statistics for a given array. +! +! Discussion: +! +! This procedure computes the average and variance of an array. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 March 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, real ( kind = 4 ) X(N), the array to be analyzed. +! +! Input, integer ( kind = 4 ) N, the dimension of the array. +! +! Output, real ( kind = 4 ) AV, the average value. +! +! Output, real ( kind = 4 ) VAR, the variance. +! +! Output, real ( kind = 4 ) XMIN, XMAX, the minimum and maximum entries. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 4 ) av + integer ( kind = 4 ) i + real ( kind = 4 ) total + real ( kind = 4 ) var + real ( kind = 4 ) x(n) + real ( kind = 4 ) xmax + real ( kind = 4 ) xmin + + xmin = x(1) + xmax = x(1) + total = 0.0E+00 + do i = 1, n + total = total + x(i) + xmin = min ( xmin, x(i) ) + xmax = max ( xmax, x(i) ) + end do + + av = total / real ( n ) + + total = 0.0E+00 + do i = 1, n + total = total + ( x(i) - av ) ** 2 + end do + var = total / real ( n - 1 ) + + return +end +subroutine trstat ( pdf, parin, av, var ) + +!*****************************************************************************80 +! +!! TRSTAT returns the mean and variance for distributions. +! +! Discussion: +! +! This procedure returns the mean and variance for a number of statistical +! distributions as a function of their parameters. +! +! The input vector PARIN is used to pass in the parameters necessary +! to specify the distribution. The number of these parameters varies +! per distribution, and it is necessary to specify an ordering for the +! parameters used to a given distribution. The ordering chosen here +! is as follows: +! +! bet +! PARIN(1) is A +! PARIN(2) is B +! bin +! PARIN(1) is Number of trials +! PARIN(2) is Prob Event at Each Trial +! chi +! PARIN(1) = df +! exp +! PARIN(1) = mu +! f +! PARIN(1) is df numerator +! PARIN(2) is df denominator +! gam +! PARIN(1) is A +! PARIN(2) is R +! nbn +! PARIN(1) is N +! PARIN(2) is P +! nch +! PARIN(1) is df +! PARIN(2) is noncentrality parameter +! nf +! PARIN(1) is df numerator +! PARIN(2) is df denominator +! PARIN(3) is noncentrality parameter +! nor +! PARIN(1) is mean +! PARIN(2) is standard deviation +! poi +! PARIN(1) is Mean +! unf +! PARIN(1) is LOW bound +! PARIN(2) is HIGH bound +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 April 2013 +! +! Author: +! +! Original FORTRAN77 version by Barry Brown, James Lovato. +! FORTRAN90 version by John Burkardt. +! +! Parameters: +! +! Input, character * ( 4 ) PDF, indicates the distribution: +! 'bet' beta distribution +! 'bin' binomial +! 'chi' chisquare +! 'exp' exponential +! 'f' F (variance ratio) +! 'gam' gamma +! 'nbn' negative binomial +! 'nch' noncentral chisquare +! 'nf' noncentral f +! 'nor' normal +! 'poi' Poisson +! 'unf' uniform +! +! Input, real ( kind = 4 ) PARIN(*), the parameters of the distribution. +! +! Output, real ( kind = 4 ) AV, the mean of the specified distribution. +! +! Output, real ( kind = 4 ) VAR, the variance of the specified distribuion. +! + implicit none + + real ( kind = 4 ) a + real ( kind = 4 ) av + real ( kind = 4 ) b + integer ( kind = 4 ) n + real ( kind = 4 ) p + real ( kind = 4 ) parin(*) + character * ( 4 ) pdf + real ( kind = 4 ) r + real ( kind = 4 ) var + real ( kind = 4 ) width + + if ( pdf == 'bet' ) then + + av = parin(1) / ( parin(1) + parin(2) ) + var = ( av * parin(2) ) / ( ( parin(1) + parin(2) ) * & + ( parin(1) + parin(2) + 1.0E+00 ) ) + + else if ( pdf == 'bin' ) then + + n = int ( parin(1) ) + p = parin(2) + av = real ( n ) * p + var = real ( n ) * p * ( 1.0E+00 - p ) + + else if ( pdf == 'chi' ) then + + av = parin(1) + var = 2.0E+00 * parin(1) + + else if ( pdf == 'exp' ) then + + av = parin(1) + var = av ** 2 + + else if ( pdf == 'f' ) then + + if ( parin(2) <= 2.0001E+00 ) then + av = -1.0E+00 + else + av = parin(2) / ( parin(2) - 2.0E+00 ) + end if + + if ( parin(2) <= 4.0001E+00 ) then + var = -1.0E+00 + else + var = ( 2.0E+00 * parin(2) ** 2 * ( parin(1) + parin(2) - 2.0E+00 ) ) / & + ( parin(1) * ( parin(2) - 2.0E+00 ) ** 2 * ( parin(2) - 4.0E+00 ) ) + end if + + else if ( pdf == 'gam' ) then + + a = parin(1) + r = parin(2) + av = r / a + var = r / a ** 2 + + else if ( pdf == 'nbn' ) then + + n = int ( parin(1) ) + p = parin(2) + av = n * ( 1.0E+00 - p ) / p + var = n * ( 1.0E+00 - p ) / p ** 2 + + else if ( pdf == 'nch' ) then + + a = parin(1) + parin(2) + b = parin(2) / a + av = a + var = 2.0E+00 * a * ( 1.0E+00 + b ) + + else if ( pdf == 'nf' ) then + + if ( parin(2) <= 2.0001E+00 ) then + av = -1.0E+00 + else + av = ( parin(2) * ( parin(1) + parin(3) ) ) & + / ( ( parin(2) - 2.0E+00 ) * parin(1) ) + end if + + if ( parin(2) <= 4.0001E+00 ) then + var = -1.0E+00 + else + a = ( parin(1) + parin(3) ) ** 2 & + + ( parin(1) + 2.0E+00 * parin(3) ) * ( parin(2) - 2.0E+00 ) + b = ( parin(2) - 2.0E+00 ) ** 2 * ( parin(2) - 4.0E+00 ) + var = 2.0E+00 * ( parin(2) / parin(1) ) ** 2 * ( a / b ) + end if + + else if ( pdf == 'nor' ) then + + av = parin(1) + var = parin(2) ** 2 + + else if ( pdf == 'poi' ) then + + av = parin(1) + var = parin(1) + + else if ( pdf == 'unf' ) then + + width = parin(2) - parin(1) + av = parin(1) + width / 2.0E+00 + var = width ** 2 / 12.0E+00 + + else + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TRSTAT - Fatal error!' + write ( *, '(a)' ) ' Illegal input value for PDF.' + stop + + end if + + return +end diff --git a/BasicWLC/dssWLC/source/readkey.f90 b/BasicWLC/dssWLC/source/readkey.f90 new file mode 100644 index 00000000..b14f8b6c --- /dev/null +++ b/BasicWLC/dssWLC/source/readkey.f90 @@ -0,0 +1,581 @@ +SUBROUTINE READKEY + ! this subroutine reads in keywords from a parameter file + ! it sets the various global variables defined in KEYS module + ! name of the parameter file is param.* where * is a keyword argument + ! if no keyword argument is supplied, the default is just a file called param + ! The EXTRAPARAMFILES keyword will allow extra parameter files to be + ! read in as well + + USE KEYS + USE INPUTPARAMS, ONLY : READLINE, READA, READF, READI, READO + USE GENUTIL + + IMPLICIT NONE + + ! ---- stuff for inputing the parameter file in free format -------- + CHARACTER*100 :: ARG ! command line argument + INTEGER :: NUMARG ! number of command line arguments + INTEGER :: NITEMS ! number of items on the line in the parameter file + INTEGER :: PF ! input file unit + LOGICAL :: FILEEND=.FALSE. ! done reading file? + CHARACTER*100 :: WORD ! keyword + ! -------------- for reading multiple parameter files -------- + INTEGER, PARAMETER :: MAXNFILES = 10 + CHARACTER*100 :: PARAMFILES(MAXNFILES) + INTEGER :: NPARAMFILES, NPARAMREAD + ! ------ for initializing stuff + INTEGER :: TIMEVAL(8), SEED + !DOUBLE PRECISION :: ROTMAT(3,3) + ! ---------------- temporary variables --------------- + INTEGER :: DUMI, I, TMPI, DUMI1, DUMI2, DUMI3 + CHARACTER*100 :: DUMSTR + LOGICAL :: LDUM, TRACKDISTSET + + ! ------------------------ + ! set variable defaults + ! ------------------------ + ACTION = 'NONE' + RNGSEED = 0 + VERBOSE = .FALSE. + + ! geometry and energy parameters + SHEARABLE = .TRUE. + STRETCHABLE = .TRUE. + COUPLED = .TRUE. + LS = 0.1D0; + LP = 1; + EC = 0; + EPERP = 1D3; + EPAR = 1D3; + GAM = 1D0; + STARTNPT = 100; + MAXNPT = 100; + FORCE = 0D0 + FINITEXT = .FALSE. + FINITSHEAR = 1D-3 + NEDGESEG = 0 + EDGELS = 0.1D0 + EDGELP = 1; + EDGEGAM = 1; + EDGEEPAR = 1D3; + EDGEEPERP = 1D3; + EDGEEC = 0; + + ! input/output + OUTFILE = '*.out' + DUMPSNAPSHOTS = .FALSE. + SNAPSHOTEVERY = 1 + SNAPSHOTFILE = '*.snap.out' + RESTART = .FALSE. + RESTARTFILE = '*.snap.out' + APPENDSNAPSHOTS = .FALSE. + SKIPREAD=1 + STARTEQUIL = .FALSE. + EQUILSAMPLETYPE = 1 + + ! monte carlo + MCPRINTFREQ = 100 + MCTOTSTEPS = 1000 + MCINITSTEPS = 100 + MCSTATSTEPS = 100 + MCOUTPUTFREQ = 100 + + ADJUSTEVERY = 1000 + FACCTARGET = 0.5D0 + FACCTOL = 0.1D0 + ADJUSTSCL = 2D0 + DOREDISC = .FALSE. + DOLOCALMOVES = .FALSE. + OUTPUTBEADWEIGHT = .FALSE. + INTuWEIGHTNPT = 500 + INTRWEIGHTNPT = 50 + + ! brownian dynamics + DELTSCL = 1D-4 + FRICTR = 1D0 + FRICTU = 1D0 + FRICTPERLEN = .FALSE. + FRICTOB = 10D0 + RADOB = 1D0 + MODOB = 1D3 + BDSTEPS = 1000 + BDPRINTEVERY = 1 + BDPRINTLOG = .FALSE. + LOGRTERM = .FALSE. + FIXBEAD1 = .FALSE. + FIXBEADMID = .FALSE. + RUNGEKUTTA = 4 + STRESSFILE = '*.stress.out' + GAUSSIANCHAIN = .FALSE. + DOBROWN = .TRUE. + ! coefficient for the relaxation force in the bead-rod brownian dynamics + ! that keeps the segment length more or less constant + BRCRELAX = 0.1; + USEPSEUDOFORCE = .TRUE. + CONSTMOD = 1D4 + MU = 0D0 + ! tracking looping first passage times + TRACKLOOPING=.FALSE. + LOOPRAD = 0.1 + LOOPFILE= "*.loop.out" + + INITRANGE = 1D0 + + USESTERICS = .FALSE. + STERRAD = 1D0 + STERSKIP=1 + STERMOD = 1D3 + + MINSEGLEN = 0.1D0 + MAXSEGLEN = 5D0 + + ! groups of chains + PARAMFROMSNAPSHOT = .FALSE. + NCONNECT = 0 + NCHAIN = 1 + SQUARELATTICE = .FALSE. + NFORCE = 0 + FORCE = 0D0 + CONNECTIONS = 0 + CONNECTPOS = .TRUE. + CONNECTUVEC = .FALSE. + CONPOSMOD = 1D3 + CONUVECMOD = 1D3 + TRACKDISTSET = .FALSE. + TRACKDIST = 0 + FIXCONNECT = .FALSE. + NFIXBEAD = 0 + FIXBEAD = 0 + FIXBOUNDARY = .FALSE. + SETSHEAR = .FALSE. + SHEARGAMMA = 0D0 + DIAMONDLATTICE = .FALSE. + NDIAMOND = (/1,1/) + WIDTHDIAMOND = -1D0 + LENDIAMOND = 1 + STARTCOLLAPSE = .FALSE. + USEBDENERGY=.FALSE. + + RESTART = .FALSE. + RESTARTFILE = 'start.out' + SKIPREAD = 0 + + EQUILBEADROD = .FALSE. + STARTEQUILLP = 1D0 + + ! ------------------------- + ! Read in all parameter files, starting with the ones specified on command line + ! -------------------------- + + PF = 55 ! i/o unit number to be used for parameter files + + ! get input parameter files from command line + NPARAMFILES = 0 + NUMARG = COMMAND_ARGUMENT_COUNT() + IF (NUMARG==0) THEN + NPARAMFILES = 1 + PARAMFILES(1) = 'param' + ARG = '' + ELSE + DO I = 1,NUMARG + CALL GETARG(I, ARG) + NPARAMFILES = NPARAMFILES + 1 + WRITE(DUMSTR,'(A)') 'param.' //TRIM(ADJUSTL(ARG)) + PARAMFILES(NPARAMFILES) = DUMSTR + ENDDO + ! reset arg to its original value + IF (NUMARG.GT.1) CALL GETARG(1,ARG) + ENDIF + + NPARAMREAD = 0 ! keep track of how many files have been read + DO WHILE (NPARAMREAD.LT.NPARAMFILES) + NPARAMREAD = NPARAMREAD + 1 + + PRINT*, 'Reading parameter file: ', PARAMFILES(NPARAMREAD) + INQUIRE(FILE=PARAMFILES(NPARAMREAD),EXIST=LDUM) + IF (.NOT.LDUM) THEN + PRINT*, 'ERROR in READKEY: Parameter file ', TRIM(ADJUSTL(PARAMFILES(NPARAMREAD))), ' does not exist.' + STOP 1 + ENDIF + OPEN(UNIT=PF, FILE=PARAMFILES(NPARAMREAD), STATUS='OLD') + + ! read in the keywords one line at a time + DO + CALL READLINE(PF,FILEEND,NITEMS) + IF (FILEEND.and.nitems.eq.0) EXIT + + ! skip empty lines + IF (NITEMS.EQ.0) CYCLE + + ! Read in the keyword for this line + CALL READA(WORD,CASESET=1) + + ! Skip any empty lines or any comment lines + IF (WORD(1:1).EQ.'#') CYCLE + + SELECT CASE(WORD) ! pick which keyword + CASE('ACTION') + CALL READA(ACTION, CASESET=1) + CASE('ADJUSTRANGE') + CALL READI(ADJUSTEVERY) + IF (NITEMS.GT.2) CALL READF(FACCTARGET) + IF (NITEMS.GT.3) CALL READF(FACCTOL) + IF (NITEMS.GT.4) CALL READF(ADJUSTSCL) + CASE('BDSTEPS') + CALL READI(BDSTEPS) + IF (NITEMS.GT.2) CALL READF(BDPRINTEVERY) + IF (NITEMS.GT.3) CALL READO(BDPRINTLOG) + CASE('BRCRELAX') + CALL READF(BRCRELAX) + CASE('CONNECT') + NCONNECT = NCONNECT + 1 + IF (NCONNECT.GT.MAXNCONNECT) THEN + PRINT*, 'TOO MANY EXPLICIT CONNECTIONS. RAISE MAXNCONNECT' + STOP 1 + ENDIF + DO DUMI = 1,4 + CALL READI(CONNECTIONS(NCONNECT,DUMI)) + ENDDO + CASE('CONNECTMOD') + CALL READF(CONPOSMOD) + CALL READF(CONUVECMOD) + CASE('CONNECTTYPE') + CALL READO(CONNECTPOS) + CALL READO(CONNECTUVEC) + CASE('CONSTMOD') + CALL READF(CONSTMOD) + CASE('COUPLED') + CALL READO(COUPLED) + CASE('DELTSCL') + CALL READF(DELTSCL) + CASE('DIAMONDLATTICE') + DIAMONDLATTICE = .TRUE. + DO DUMI = 1,2 + CALL READI(NDIAMOND(DUMI)) + ENDDO + CALL READi(LENDIAMOND) + IF (NITEMS.GT.4) CALL READF(WIDTHDIAMOND) + CASE('DOLOCALMOVES') + DOLOCALMOVES = .TRUE. ! do single bead moves for 1-chain MC + CASE('EC') + CALL READF(EC) + CASE('EDGESEGS') + CALL READI(NEDGESEG) + CALL READF(EDGELS) + CALL READF(EDGELP) + CALL READF(EDGEGAM) + CALL READF(EDGEEPAR) + CALL READF(EDGEEPERP) + CALL READF(EDGEEC) + CASE('EPAR') + CALL READF(EPAR) + CASE('EPERP') + CALL READF(EPERP) + CASE('FINITEXT') + IF (NITEMS.GT.1) THEN + CALL READF(FINITSHEAR) + ENDIF + FINITEXT = .TRUE. + CASE('FIXBEAD') + NFIXBEAD = NFIXBEAD + 1 + IF (NFIXBEAD.GT.MAXFIXBEAD) THEN + PRINT*, 'ERROR: too many fixed bead lines' + STOP 1 + ENDIF + CALL READI(FIXBEAD(NFIXBEAD,1)) + IF (NITEMS.GT.2) THEN + CALL READI(FIXBEAD(NFIXBEAD,2)) + CALL READO(LDUM) + IF (LDUM) FIXBEAD(NFIXBEAD,3) = 1 + CALL READO(LDUM) + IF (LDUM) FIXBEAD(NFIXBEAD,4) = 1 + ELSE + FIXBEAD(NFIXBEAD,2) = 1 + ENDIF + CASE('FIXBEAD1') + FIXBEAD1 = .TRUE. + CASE('FIXBEADMID') + FIXBEADMID = .TRUE. + CASE('FIXBOUNDARY') + IF (NITEMS.GT.1) THEN + CALL READO(FIXBOUNDARY(1)) + CALL READO(FIXBOUNDARY(2)) + ENDIF + IF (NITEMS.GT.3) THEN + CALL READO(FIXBOUNDARY(3)) + CALL READO(FIXBOUNDARY(4)) + ENDIF + CASE('FIXCONNECT') + FIXCONNECT=.TRUE. + CASE('FORCE') + NFORCE = NFORCE + 1 + IF (NFORCE.GT.MAXNFORCE) THEN + PRINT*, 'TOO MANY FORCE! RAISE MAXNFORCE.' + stop 1 + ENDIF + CALL READI(FORCEBEAD(NFORCE,1)) + CALL READI(FORCEBEAD(NFORCE,2)) + DO DUMI = 1,3 + CALL READF(FORCE(NFORCE,DUMI)) + ENDDO + CASE('FRICT') + CALL READF(FRICTR) + CALL READF(FRICTU) + IF (NITEMS.GT.3) THEN + CALL READO(FRICTPERLEN) + ENDIF + CASE('GAM') + CALL READF(GAM) + CASE('GAUSSIANCHAIN') + GAUSSIANCHAIN = .TRUE. + CASE('INITRANGE') + DO DUMI = 1,4 + CALL READF(INITRANGE(DUMI)) + ENDDO + CASE('LOGRTERM') + LOGRTERM = .TRUE. + CASE('LOOPING') + TRACKLOOPING = .TRUE. + IF (NITEMS.GT.1) CALL READF(LOOPRAD) + IF (NITEMS.GT.2) CALL READA(LOOPFILE) + CASE('LP') + CALL READF(LP) + CASE('LS') + CALL READF(LS) + CASE('MCPRINTFREQ') + CALL READI(MCPRINTFREQ) + IF (NITEMS.GT.2) THEN + CALL READI(MCOUTPUTFREQ) + ELSE + MCOUTPUTFREQ = MCPRINTFREQ + ENDIF + CASE('MCSTEPS') + CALL READI(MCTOTSTEPS) + IF (NITEMS.GT.2) THEN + CALL READI(MCSTATSTEPS) + endif + IF (NITEMS.GT.3) THEN + CALL READI(MCINITSTEPS) + ENDIF + CASE('MU') + CALL READF(MU) + CASE('NCHAIN') + CALL READI(NCHAIN) + CASE('NOBROWN') + DOBROWN = .FALSE. + CASE('NPT') + ! starting number of points; maximal number + ! if not specified, assuming maximal number is the starting number + CALL READI(STARTNPT) + IF (NITEMS.GT.2) THEN + CALL READI(MAXNPT) + ELSE + MAXNPT = STARTNPT + ENDIF + CASE('OBSTACLE') + CALL READF(RADOB) + CALL READF(MODOB) + CALL READF(FRICTOB) + CASE('OUTFILE') + CALL READA(OUTFILE) + CASE('OUTPUTBEADWEIGHT') + ! output the partition function associated with each mobile bead + ! integrating over R and U vecs separately + OUTPUTBEADWEIGHT = .TRUE. + IF (NITEMS.GT.1) THEN + ! number of integration points in each dim when integrating over u vector + CALL READI(INTUWEIGHTNPT) + ENDIF + IF (NITEMS.GT.2) THEN + CALL READI(INTRWEIGHTNPT) + ENDIF + CASE('PARAMFROMSNAPSHOT') + IF (NITEMS.GT.1) THEN + CALL READO(PARAMFROMSNAPSHOT) + ELSE + PARAMFROMSNAPSHOT = .TRUE. + ENDIF + CASE('REDISCRETIZE') + DOREDISC = .TRUE. + IF (NITEMS.GT.1) CALL READF(MINSEGLEN) + IF (NITEMS.GT.2) CALL READF(MAXSEGLEN) + CASE('RESTART') + RESTART = .TRUE. + IF (NITEMS.GT.1) CALL READA(RESTARTFILE) + IF (NITEMS.GT.2) CALL READI(SKIPREAD) + CASE('RNGSEED') + CALL READI(RNGSEED) + CASE('RUNGEKUTTA') + CALL READI(RUNGEKUTTA) + CASE('SETSHEAR') + SETSHEAR = .TRUE. + CALL READF(SHEARGAMMA) + CASE('SHEARABLE') + CALL READO(SHEARABLE) + CASE('SNAPSHOTS') + DUMPSNAPSHOTS = .TRUE. + IF (NITEMS.GT.1) CALL READI(SNAPSHOTEVERY) + IF (NITEMS.GT.2) CALL READA(SNAPSHOTFILE) + IF (NITEMS.GT.3) CALL READO(APPENDSNAPSHOTS) + CASE('STARTEQUIL') + ! start with properly sampled equilibrium conformations + STARTEQUIL = .TRUE. + IF (NITEMS.GT.1) CALL READI(EQUILSAMPLETYPE) + IF (NITEMS.GT.2) THEN + EQUILBEADROD = .TRUE. + CALL READF(STARTEQUILLP) + ENDIF + CASE('SQUARELATTICE') + SQUARELATTICE = .TRUE. + CASE('STARTCOLLAPSE') + STARTCOLLAPSE = .TRUE. + CASE('STERICS') + USESTERICS = .TRUE. + CALL READF(STERRAD) + IF (NITEMS.GT.2) CALL READI(STERSKIP) + IF (NITEMS.GT.3) CALL READF(STERMOD) + CASE('STRESSFILE') + CALL READA(STRESSFILE) + CASE('STRETCHABLE') + CALL READO(STRETCHABLE) + CASE('TRACKDIST') + TRACKDISTSET = .TRUE. + DO DUMI = 1,4 + CALL READI(TRACKDIST(DUMI)) + ENDDO + CASE('USEBDENERGY') + USEBDENERGY = .TRUE. ! use BD energy for MC calculations + CASE('USEPSEUDOFORCE') + ! use pseudo-potential force for bead-rod BD simulations? + CALL READO(USEPSEUDOFORCE) + CASE('VERBOSE') + CALL READO(VERBOSE) + CASE DEFAULT + print*, 'ERROR: unidentified keyword ', TRIM(WORD), " Will ignore." + END SELECT + ENDDO + CLOSE(PF) + ENDDO + + ! ----- set some more defaults ----- + IF (.NOT.TRACKDISTSET) THEN + TRACKDIST = (/1,1,STARTNPT,1/) + ENDIF + + ! ----------------- + ! check validity of some values, raise errors or adjust as necessary + ! ----------------- + + IF (STARTNPT.LE.0.OR.MAXNPT.LT.STARTNPT) THEN + PRINT*, 'ERROR IN NPT VALUES',STARTNPT,MAXNPT + STOP 1 + ENDIF + IF (EPERP.LT.0) THEN + PRINT*, 'ERROR IN EPERP VALUE', EPERP + STOP 1 + ENDIF + IF (EPAR.LT.0) THEN + PRINT*, 'ERROR IN EPAR VALUE', EPAR + STOP 1 + ENDIF + IF (LS.LT.0) THEN + PRINT*, 'ERROR IN LS VALUE', LS + STOP 1 + ENDIF + IF (LP.LT.0) THEN + PRINT*, 'ERROR IN LP VALUE', LP + STOP 1 + ENDIF + + IF (DIAMONDLATTICE) THEN + ! reset number of chains and length of chains based on diamond lattice + NCHAIN = 2*(NDIAMOND(1)+NDIAMOND(2)-1) + MAXNPT = 2*MINVAL(NDIAMOND)*LENDIAMOND + 1 + IF (WIDTHDIAMOND.LT.0) THEN + WIDTHDIAMOND = GAM*LS*LENDIAMOND/SQRT(2D0)*2 + ENDIF + PRINT*, 'Recalculating nchain and maxnpt for diamond lattice:', NCHAIN, MAXNPT, WIDTHDIAMOND + ENDIF + + IF (TRACKDIST(1).LE.0.OR.TRACKDIST(1).GT.MAXNPT& + & .OR.TRACKDIST(3).LE.0.OR.TRACKDIST(3).GT.MAXNPT& + & .OR.TRACKDIST(2).LE.0.OR.TRACKDIST(2).GT.NCHAIN & + & .OR.TRACKDIST(4).LE.0.OR.TRACKDIST(4).GT.NCHAIN) THEN + PRINT*, 'ERROR: BAD TRACKDIST', TRACKDIST + STOP 1 + ENDIF + + DO DUMI = 1,NFORCE + IF (FORCEBEAD(DUMI,1).LE.0.OR.FORCEBEAD(DUMI,1).GT.MAXNPT & + & .OR.FORCEBEAD(DUMI,2).LE.0.OR.FORCEBEAD(DUMI,2).GT.NCHAIN) THEN + PRINT*, 'ERROR: BAD FORCE', FORCEBEAD(DUMI,:) + STOP 1 + ENDIF + ENDDO + + ! ----------- fix file names ----------- + CALL REPLACESUBSTR(OUTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(SNAPSHOTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(RESTARTFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(STRESSFILE,'*',TRIM(ADJUSTL(ARG))) + CALL REPLACESUBSTR(LOOPFILE,'*',TRIM(ADJUSTL(ARG))) + ! --------------------------- + + ! Initiate random number generator + IF (RNGSEED.EQ.0) THEN + ! use the current time of day in milliseconds + CALL DATE_AND_TIME(VALUES=TIMEVAL) + SEED = TIMEVAL(5)*3600*1000 + TIMEVAL(6)*60*1000 + TIMEVAL(7)*1000 + TIMEVAL(8) + ELSEIF (RNGSEED.EQ.-1) THEN + ! use the last 5 characters in the command-line argument + SEED = STRING2NUM(TRIM(ADJUSTL(ARG))) + ELSEIF (RNGSEED.EQ.-2) THEN + ! use the last 4 characters in the command-line argument + ! and additionally the millisecond time + CALL DATE_AND_TIME(VALUES=TIMEVAL) + SEED = STRING2NUM(TRIM(ADJUSTL(ARG)),TIMEVAL(8)) + ELSE + ! use this seed directly + SEED = RNGSEED + ENDIF + + print*, 'Initiating Mersenne twister random number generator with seed:', SEED + CALL SGRND(SEED) + + print*, '------------Parameter values : -------------------' + print*, 'ACTION: ', TRIM(ADJUSTL(ACTION)) + print*, 'Output file: ', TRIM(OUTFILE) + IF (DUMPSNAPSHOTS) THEN + PRINT*, 'Dumping snapshot every', SNAPSHOTEVERY,'steps. In file:', TRIM(ADJUSTL(SNAPSHOTFILE)) + ENDIF + IF (RESTART) THEN + PRINT*, 'Restarting from file:', trim(adjustl(RESTARTFILE)) + ENDIF + print*, 'Number of chains:', NCHAIN + print*, 'STARTNPT, MAXNPT, LS:', STARTNPT, MAXNPT,LS + PRINT*, 'LP, GAM, EPAR, EPERP, EC:', LP, GAM, EPAR, EPERP, EC + PRINT*, 'FINITE EXTENSION?:', FINITEXT, FINITSHEAR + PRINT*, 'FRICTION COEFFICIENTS:', FRICTR, FRICTU + PRINT*, 'OBSTACLE:', RADOB,MODOB,FRICTOB + PRINT*, 'CONSTRAINT, STERIC MODULUS, mu:', CONSTMOD, STERMOD, MU + IF (USESTERICS) THEN + PRINT*, 'Using sterics, with radius:', STERRAD + ENDIF + PRINT*, 'NUMBER OF CONNECTIONS:', NCONNECT, SQUARELATTICE + PRINT*, 'FIXED CONNECTIONS?:', FIXCONNECT + print*, 'Tracking distance btwn points:', TRACKDIST + IF (NFIXBEAD.GT.0) THEN + PRINT*, 'FIXED BEADS:' + DO DUMI = 1,NFIXBEAD + PRINT*, FIXBEAD(DUMI,:) + ENDDO + ENDIF + IF (ANY(FIXBOUNDARY)) PRINT*, 'FIXING BOUNDARIES.', FIXBOUNDARY + IF (GAUSSIANCHAIN) PRINT*, 'Treating chain as a plain gaussian with stretch modulus EPAR' + IF (STARTEQUIL) PRINT*, 'Starting from equilibrated configurations.' + IF (NEDGESEG.GT.0) PRINT*, 'For ', NEDGESEG, ' edge segments parameters are:', & + & EDGELS, EDGELP, EDGEGAM, EDGEEPAR, EDGEEPERP, EDGEEC + print*, '----------------------------------------------------' + + +END SUBROUTINE READKEY diff --git a/BasicWLC/dssWLC/source/redisc.f90 b/BasicWLC/dssWLC/source/redisc.f90 new file mode 100644 index 00000000..1bbcb45d --- /dev/null +++ b/BasicWLC/dssWLC/source/redisc.f90 @@ -0,0 +1,1107 @@ +MODULE REDISC + ! utilities for rediscretizing the chain on the fly + USE CHAINUTIL, ONLY : CHAIN + IMPLICIT NONE + + DOUBLE PRECISION, ALLOCATABLE :: PARAMDATA(:,:) + INTEGER :: NPARAMDATA + LOGICAL :: PARAMDATASET = .FALSE. + + +CONTAINS + ! for two segments, criterion to add a bead to both: + ! imagine all the possible position of a center bead on one of them (intersection of two balls of radius LS/2). + !Circumscribe this set by a cylinder for ease of computation + !(height = L-d, radius = sqrt(L^2-d^2)/2, where d is distance btwn points; + ! cylinder axis is vector btwn points + ! if these potential cylinders for the two segments overlap, then need to + ! add center point for each of the two segments + ! for removing points, check every even bead for possible removal in the same way + ! in a given run of this function, at most one bead is added to each segment + ! and at most every other bead is removed + ! removal happens before addition + + + SUBROUTINE REDISCADD(CHAINP,DELE) + ! rediscretize chain, adding beads where potential steric conflicts exist + ! set of possible positions is circumscribed by cylinder for simplicity of calculation + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: S1,S2, NADD, CH + LOGICAL :: HASCONFLICT(CHAINP%NPT), CYLSET(CHAINP%NPT), INTERSECT + DOUBLE PRECISION :: LS1, LS2, LS3, LS4, PT1(3), PT2(3), PT3(3), PT4(3) + DOUBLE PRECISION :: DIFF(3), NDIFF, TMPDELE + INTEGER :: ADDSEG(CHAINP%NPT) + DOUBLE PRECISION :: HCYL(CHAINP%NPT), RCYL(CHAINP%NPT), AXCYL(3,CHAINP%NPT),CENTCYL(3,CHAINP%NPT) + DOUBLE PRECISION :: CUMLEN1, CUMLEN2 + + + ! for all pairs of segments, check for possible conflict + + NADD = 0 + HASCONFLICT = .FALSE. + CYLSET = .FALSE. + + CUMLEN1 = 0D0 + DO S1 = 1,CHAINP%NPT-1 + PT1 = CHAINP%POS(:,S1); PT2 = CHAINP%POS(:,S1+1) + LS1 = CHAINP%LS(S1)/2+CHAINP%STERRAD; LS2 = LS1 + + CUMLEN1 = CUMLEN1 + CHAINP%LS(S1) + + + CUMLEN2 = 0D0 + DO S2 = 1,CHAINP%NPT + IF (S2.GT.1) CUMLEN2 = CUMLEN2 + CHAINP%LS(S2-1) + IF (S2.EQ.S1.OR.S2.EQ.S1+1) CYCLE + IF (ABS((CUMLEN1-CHAINP%LS(S1)/2)-(CUMLEN2)).LE.2*CHAINP%STERRAD) CYCLE + + PT3 = CHAINP%POS(:,S2); + LS3 = CHAINP%STERRAD + + CALL INTERSECT3SPHERE(PT1,PT2,PT3,LS1,LS2,LS3,INTERSECT) + + ! IF (S1.EQ.13.AND.S2.EQ.5) THEN + ! PRINT*, 'TESTX0:', PT1, PT2 + ! PRINT*, 'TESTX1:', INTERSECT,CHAINP%LS(S1)/2, SQRT(DOT_PRODUCT(PT2-PT1,PT2-PT1)) + ! ENDIF + + IF (INTERSECT) THEN + !PRINT*, 'TESTX ADDBEAD CONFLICT:', S1,S2 + + IF (CHAINP%LS(S1)/2.GT.CHAINP%MINSEGLEN) THEN + NADD = NADD + 1 + ADDSEG(NADD) = S1 + HASCONFLICT(S1) = .TRUE. + ENDIF + + EXIT + ENDIF + + ENDDO + + ENDDO + + !PRINT*, 'TESTX3:', ADDSEG(1:NADD) + + ! Add beads to all selected segments + DELE = 0 + DO S1 = 1,NADD + !PRINT*, 'TESTX4:', S1, ADDSEG(S1), nadd + CALL ADDBEAD(CHAINP,ADDSEG(S1),TMPDELE) + DO S2 = S1+1,NADD + IF (ADDSEG(S2).GT.ADDSEG(S1)) ADDSEG(S2) = ADDSEG(S2)+1 + ENDDO +! ADDSEG(S1+1:NADD) = ADDSEG(S1+1:NADD)+1 + DELE = DELE + TMPDELE + ENDDO + + END SUBROUTINE REDISCADD + + SUBROUTINE REDISCADDOLD(CHAINP,DELE) + ! rediscretize chain, adding beads where potential steric conflicts exist + ! set of possible positions is circumscribed by cylinder for simplicity of calculation + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: S1,S2, NADD, CH + LOGICAL :: HASCONFLICT(CHAINP%NPT), CYLSET(CHAINP%NPT), INTERSECT + DOUBLE PRECISION :: LS1, LS2, LS3, LS4, PT1(3), PT2(3), PT3(3), PT4(3) + DOUBLE PRECISION :: DIFF(3), NDIFF, TMPDELE + INTEGER :: ADDSEG(CHAINP%NPT) + DOUBLE PRECISION :: HCYL(CHAINP%NPT), RCYL(CHAINP%NPT), AXCYL(3,CHAINP%NPT),CENTCYL(3,CHAINP%NPT) + DOUBLE PRECISION :: CUMLEN1, CUMLEN2 + + + ! for all pairs of segments, check for possible conflict + + NADD = 0 + HASCONFLICT = .FALSE. + CYLSET = .FALSE. + + CUMLEN1 = 0D0 + DO S1 = 1,CHAINP%NPT-1 + PT1 = CHAINP%POS(:,S1); PT2 = CHAINP%POS(:,S1+1) + LS1 = CHAINP%LS(S1)/2+CHAINP%STERRAD; LS2 = LS1 + + CUMLEN1 = CUMLEN1 + CHAINP%LS(S1) + + IF (HASCONFLICT(S1)) CYCLE + + CUMLEN2 = 0D0 + DO S2 = 1,CHAINP%NPT-1 + CUMLEN2 = CUMLEN2 + CHAINP%LS(S2) + IF (s1.eq.s2) CYCLE + !IF (S2.EQ.S1) CYCLE + IF (ABS((CUMLEN1-CHAINP%LS(S1)/2)-(CUMLEN2-CHAINP%LS(S2)/2)).LE.2*CHAINP%STERRAD) CYCLE + + + PT3 = CHAINP%POS(:,S2); PT4 = CHAINP%POS(:,S2+1) + LS3 = CHAINP%LS(S2)/2+CHAINP%STERRAD; LS4 = LS3 + + CALL CHECKCONFLICT(PT1,PT2,LS1,LS2,PT3,PT4,LS3,LS4,& + & CYLSET(S1),HCYL(S1),RCYL(S1),AXCYL(:,S1),CENTCYL(:,S1),& + & CYLSET(S2), HCYL(S2), RCYL(S2), AXCYL(:,S2), CENTCYL(:,S2), INTERSECT) + !print*, 'testx2:', s1, s2, intersect + + IF (INTERSECT) THEN + !PRINT*, 'TESTX ADDBEAD CONFLICT:', S1,S2 + + IF (CHAINP%LS(S1)/2.GT.2*CHAINP%STERRAD.AND.CHAINP%LS(S1)/2.GT.CHAINP%MINSEGLEN) THEN + NADD = NADD + 1 + ADDSEG(NADD) = S1 + HASCONFLICT(S1) = .TRUE. + ENDIF + + IF (.NOT.HASCONFLICT(S2).AND.CHAINP%LS(S2)/2.GT.2*CHAINP%STERRAD& + & .AND.CHAINP%LS(S2)/2.GT.CHAINP%MINSEGLEN) THEN + NADD = NADD + 1 + ADDSEG(NADD) = S2 + HASCONFLICT(S2) = .TRUE. + ENDIF + EXIT + ENDIF + + ENDDO + + ENDDO + + !PRINT*, 'TESTX3:', ADDSEG(1:NADD) + + ! Add beads to all selected segments + DELE = 0 + DO S1 = 1,NADD + !PRINT*, 'TESTX4:', S1, ADDSEG(S1) + CALL ADDBEAD(CHAINP,ADDSEG(S1),TMPDELE) + DO S2 = S1+1,NADD + IF (ADDSEG(S2).GT.ADDSEG(S1)) ADDSEG(S2) = ADDSEG(S2)+1 + ENDDO +! ADDSEG(S1+1:NADD) = ADDSEG(S1+1:NADD)+1 + DELE = DELE + TMPDELE + ENDDO + + END SUBROUTINE REDISCADDOLD + + SUBROUTINE REDISCREMOVE(CHAINP,DELE) + ! rediscretize chain by removing beads where no potential steric conflicts exist + ! a conflict is if all possible positions of the bead could sterically clash with current position of some other bead + ! will not remove neighboring bead + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: B, C, NRM, CH + LOGICAL :: HASCONFLICT(CHAINP%NPT), CYLSET(CHAINP%NPT), INTERSECT, WILLREMOVE(CHAINP%NPT) + DOUBLE PRECISION :: LS1, LS2, LS3, LS4, PT1(3), PT2(3), PT3(3), PT4(3) + DOUBLE PRECISION :: DIFF(3), NDIFF, TMPDELE, CUMLEN1, CUMLEN2 + INTEGER :: RMBEADS(CHAINP%NPT) + DOUBLE PRECISION :: HCYL(CHAINP%NPT), RCYL(CHAINP%NPT), AXCYL(3,CHAINP%NPT),CENTCYL(3,CHAINP%NPT) + + + + ! for all beads, check if they can be removed + HASCONFLICT = .FALSE. + WILLREMOVE = .FALSE. + CYLSET = .FALSE. + NRM = 0 + + CUMLEN1 = CHAINP%LS(1) + DO B = 2,CHAINP%NPT-1 + CUMLEN1 = CUMLEN1 + CHAINP%LS(B) + ! previous bead is going to be removed so keep this one + IF (WILLREMOVE(B-1)) CYCLE + + PT1 = CHAINP%POS(:,B-1); PT2 = CHAINP%POS(:,B+1) + LS1 = CHAINP%LS(B-1)+CHAINP%STERRAD; LS2 = CHAINP%LS(B)+CHAINP%STERRAD + + CUMLEN2 = 0 + DO C = 1,CHAINP%NPT + IF (C.GT.1) CUMLEN2 = CUMLEN2 + CHAINP%LS(C-1) + IF (abs(b-c).le.1) CYCLE + IF (ABS(CUMLEN1-CUMLEN2).LT.2*CHAINP%STERRAD) CYCLE + + PT3 = CHAINP%POS(:,C); + LS3 = CHAINP%STERRAD; + CALL INTERSECT3SPHERE(PT1,PT2,PT3,LS1,LS2,LS3,INTERSECT) + IF (INTERSECT) THEN + !PRINT*, 'TESTX CONFLICT:', B,C, LS1-CHAINP%STERRAD, LS2-CHAINP%STERRAD, LS3 + HASCONFLICT(B) = .TRUE.; + EXIT + ENDIF + + ENDDO + + IF (.NOT.HASCONFLICT(B).AND. CHAINP%LS(B-1)+CHAINP%LS(B).LE.CHAINP%MAXSEGLEN) THEN + ! bead has no potential steric conflicts and can be removed + !PRINT*, 'NO CONFLICT:', B + NRM = NRM +1 + RMBEADS(NRM) = B + WILLREMOVE(B) = .TRUE. + ENDIF + ENDDO + + ! DO B = 2,CHAINP%NPT + ! DIFF = CHAINP%POS(:,B)-CHAINP%POS(:,B-1) + ! PRINT*, 'TESTX0:', B, SQRT(DOT_PRODUCT(DIFF,DIFF)),CHAINP%LS(B) + ! ENDDO + + ! Remove all the beads marked for removal + DELE = 0 + DO B = 1,NRM + CALL REMOVEBEAD(CHAINP,RMBEADS(B),TMPDELE) + RMBEADS(B+1:NRM) = RMBEADS(B+1:NRM)-1 + DELE = DELE + TMPDELE + ENDDO + + + END SUBROUTINE REDISCREMOVE + + SUBROUTINE INTERSECT3SPHERE(P1,P2,P3,RAD1,RAD2,RAD3,INTERSECT) + ! check whether 3 spheres centered at points P1,P2,P3 + ! with radii RAD1, RAD2, RAD3 intersect + ! WARNING: for now this just checks that each pair of balls intersects + ! this is not sufficient for there to be a common intersection + USE GENUTIL, ONLY : NORMALIZE + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: P1(3), P2(3), P3(3), RAD1,RAD2,RAD3 + LOGICAL, INTENT(OUT) :: INTERSECT + DOUBLE PRECISION :: DIFF12(3), DIFF13(3), DIFF23(3), EX(3), EY(3) + DOUBLE PRECISION :: D12, D13, D23, DVAL, IVAL, JVAL, XVAL, YVAL + + ! first make sure each pair intersects + DIFF12=P2-P1 + D12 = DOT_PRODUCT(DIFF12,DIFF12) + IF (D12.GT.(RAD1+RAD2)**2) THEN + INTERSECT = .FALSE. + RETURN + ENDIF + + DIFF23 = P3-P2 + D23 = DOT_PRODUCT(DIFF23,DIFF23) + IF (D23.GT.(RAD2+RAD3)**2) THEN + INTERSECT = .FALSE. + RETURN + ENDIF + + DIFF13 = P3-P1 + D13 = DOT_PRODUCT(DIFF13,DIFF13) + IF (D13.GT.(RAD1+RAD3)**2) THEN + INTERSECT = .FALSE. + RETURN + ENDIF + + INTERSECT = .TRUE. + ! calculate possible intersection, using algorithm from wikipedia + ! DVAL = SQRT(D12) + ! EX = DIFF12/DVAL + ! IVAL = DOT_PRODUCT(EX,DIFF13) + ! EY = DIFF13-IVAL*EX + ! CALL NORMALIZE(EY) + ! JVAL = DOT_PRODUCT(EY,DIFF13) + + ! XVAL = (RAD1**2-RAD2**2+DVAL**2)/(2*DVAL) + ! YVAL = (RAD1**2-RAD3**2+IVAL**2+JVAL**2)/(2*JVAL) - IVAL/JVAL*XVAL + + ! INTERSECT = (RAD1**2 - XVAL**2-YVAL**2).GT.0 + + END SUBROUTINE INTERSECT3SPHERE + + SUBROUTINE REDISCREMOVEOLD(CHAINP,DELE) + ! rediscretize chain by removing beads where no potential steric conflicts exist + ! for each even bead: + ! for each other bead, consider all the possible positions given the neighbor beads + ! if any steric overlap is possible, then there is a conflict + ! if no conflict remove the even bead. + ! set of possible positions is circumscribed by cylinder for simplicity of calculation + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER :: B, C, NRM, CH + LOGICAL :: HASCONFLICT(CHAINP%NPT), CYLSET(CHAINP%NPT), INTERSECT, WILLREMOVE(CHAINP%NPT) + DOUBLE PRECISION :: LS1, LS2, LS3, LS4, PT1(3), PT2(3), PT3(3), PT4(3) + DOUBLE PRECISION :: DIFF(3), NDIFF, TMPDELE, CUMLEN1, CUMLEN2 + INTEGER :: RMBEADS(CHAINP%NPT) + DOUBLE PRECISION :: HCYL(CHAINP%NPT), RCYL(CHAINP%NPT), AXCYL(3,CHAINP%NPT),CENTCYL(3,CHAINP%NPT) + + + + ! 1) for all beads, check if they can be removed + HASCONFLICT = .FALSE. + WILLREMOVE = .FALSE. + CYLSET = .FALSE. + NRM = 0 + + CUMLEN1 = CHAINP%LS(1) + DO B = 2,CHAINP%NPT-1 + + CUMLEN1 = CUMLEN1 + CHAINP%LS(B) + IF (HASCONFLICT(B)) CYCLE ! previous conflict already found + ! previous bead is going to be removed so keep this one + IF (WILLREMOVE(B-1)) CYCLE + + PT1 = CHAINP%POS(:,B-1); PT2 = CHAINP%POS(:,B+1) + LS1 = CHAINP%LS(B-1)+CHAINP%STERRAD; LS2 = CHAINP%LS(B)+CHAINP%STERRAD + + ! PRINT*, 'TESTX1:', B, CHAINP%LS(B-1), CHAINP%STERRAD, ls1 + + ! currently not checking the edge beads; should probably fix this at some point + ! Also, many pairs of beads get checked twice the way this + !is currently set up; should fix this at some point too + ! (probably need to save entire matrix of possible conflicts) + CUMLEN2 = CHAINP%LS(1) + DO C = 2,CHAINP%NPT-1 + CUMLEN2 = CUMLEN2 + CHAINP%LS(C) + IF (ABS(B-C).LE.2) CYCLE + IF (ABS(CUMLEN1-CUMLEN2).LT.2*CHAINP%STERRAD) CYCLE + + PT3 = CHAINP%POS(:,C-1); PT4 = CHAINP%POS(:,C+1) + LS3 = CHAINP%LS(C-1)+CHAINP%STERRAD; LS4 = CHAINP%LS(C)+CHAINP%STERRAD + CALL CHECKCONFLICT(PT1,PT2,LS1,LS2,PT3,PT4,LS3,LS4,& + & CYLSET(B),HCYL(B),RCYL(B),AXCYL(:,B),CENTCYL(:,B),& + & CYLSET(C), HCYL(C), RCYL(C), AXCYL(:,C), CENTCYL(:,C), INTERSECT) + IF (INTERSECT) THEN + !PRINT*, 'TESTX CONFLICT:', B,C, LS1, LS2, LS3, LS4 + HASCONFLICT(B) = .TRUE.; HASCONFLICT(C) = .TRUE. + EXIT + ENDIF + + ENDDO + + IF (.NOT.HASCONFLICT(B).AND. CHAINP%LS(B-1)+CHAINP%LS(B).LE.CHAINP%MAXSEGLEN) THEN + ! bead has no potential steric conflicts and can be removed + !PRINT*, 'NO CONFLICT:', B + NRM = NRM +1 + RMBEADS(NRM) = B + WILLREMOVE(B) = .TRUE. + ENDIF + ENDDO + + ! Remove all the beads marked for removal + DELE = 0 + DO B = 1,NRM + CALL REMOVEBEAD(CHAINP,RMBEADS(B),TMPDELE) + RMBEADS(B+1:NRM) = RMBEADS(B+1:NRM)-1 + DELE = DELE + TMPDELE + ENDDO + + + END SUBROUTINE REDISCREMOVEOLD + + SUBROUTINE CHECKCONFLICT(PT1,PT2,LS1,LS2,PT3,PT4,LS3,LS4,& + & CYLSET1,HCYL1,RCYL1,AXCYL1,CENTCYL1,& + & CYLSET2, HCYL2, RCYL2, AXCYL2, CENTCYL2, CONFLICT) + ! check whether two segments have a potential conflict + ! between point A at max distance LS1 from PT1 & LS2 from PT2 + ! and point B at max distance LS3 from PT3 & LS4 from PT4 + ! CYLSET says whether cylinder info has already been set or not + ! will be set if isn't already + USE CYLINDERUTIL, ONLY : CYLINDERINTERSECT + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: PT1(3), PT2(3), LS1, LS2, PT3(3), PT4(3), LS3, LS4 + DOUBLE PRECISION, INTENT(INOUT) :: HCYL1, RCYL1, HCYL2, RCYL2, AXCYL1(3), AXCYL2(3), CENTCYL1(3), CENTCYL2(3) + LOGICAL, INTENT(INOUT) :: CYLSET1, CYLSET2 + LOGICAL, INTENT(OUT) :: CONFLICT + DOUBLE PRECISION :: DIFF(3), NDIFF, RAD13, RAD23, RAD14, RAD24 + + CONFLICT = .FALSE. + RAD13 = (LS1+LS3)**2; RAD23 = (LS2+LS3)**2 + RAD14 = (LS1+LS4)**2; RAD24 = (LS2+LS4)**2 + + ! do some preliminary checking + ! if any pair of the spheres can't intersect then no intersection possible + DIFF = PT3-PT1 + NDIFF = DOT_PRODUCT(DIFF,DIFF) + IF (NDIFF.GT.RAD13) RETURN + + DIFF = PT4 - PT1 + NDIFF = DOT_PRODUCT(DIFF,DIFF) + IF (NDIFF.GT.RAD14) RETURN + + DIFF = PT3-PT2 + NDIFF = DOT_PRODUCT(DIFF,DIFF) + IF (NDIFF.GT.RAD23) RETURN + + DIFF = PT4-PT2 + NDIFF = DOT_PRODUCT(DIFF,DIFF) + IF (NDIFF.GT.RAD24) RETURN + + ! define the enveloping cylinders + IF (.NOT.CYLSET1) THEN + CALL ENVELOPECYLINDER(PT1,PT2,LS1,LS2,& + & HCYL1,RCYL1,AXCYL1,CENTCYL1) + CYLSET1 = .TRUE. + IF (HCYL1.LT.0) THEN + PRINT*, 'ERROR IN CHECKCONFLICT: impossible point exists', PT1, PT2, LS1, LS2 + STOP 2 + ENDIF + ENDIF + + IF (.NOT.CYLSET2) THEN + CALL ENVELOPECYLINDER(PT3,PT4,LS3,LS4,& + & HCYL2,RCYL2,AXCYL2,CENTCYL2) + CYLSET2 = .TRUE. + IF (HCYL2.LT.0) THEN + PRINT*, 'ERROR IN REDISCMV1: impossible point exists', PT3, PT4, LS3, LS4 + STOP 2 + ENDIF + ENDIF + + ! Check if enveloping cylinders intersect + CONFLICT = CYLINDERINTERSECT(RCYL1,RCYL2,HCYL1,HCYL2,& + & CENTCYL1,AXCYL1,CENTCYL2,AXCYL2) + + + END SUBROUTINE CHECKCONFLICT + + SUBROUTINE ENVELOPECYLINDER(PT1, PT2, RAD1, RAD2, HCYL, RCYL, AXCYL, CENTCYL) + ! for a particular pair of points and radii + ! define a cylinder enveloping the intersection of two filled spheres + ! centered at those points + ! HCYL = Height of cylinder + ! RCYL = radius of cylinder + ! AXCYL = normalized axis of cylinder + ! CENTCYL = center of cylinder + ! returns negative HCYL if the two spheres do not intersect + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: PT1(3), PT2(3), RAD1, RAD2 + DOUBLE PRECISION, INTENT(OUT) :: HCYL, RCYL, AXCYL(3), CENTCYL(3) + DOUBLE PRECISION :: DIFF(3), D, DEL1, DEL2 + + DIFF = PT2-PT1 + D = SQRT(DOT_PRODUCT(DIFF,DIFF)) + IF (D.GT.RAD1+RAD2) THEN + HCYL = -1 + RETURN + ENDIF + + DEL1 = MIN(RAD1,RAD2) + DEL2 = MAX(RAD1,RAD2) + IF (DEL2.GT.DEL1+D) THEN ! one sphere inside another + HCYL = 2*DEL1; RCYL = DEL1 + AXCYL = DIFF/D + IF (RAD1.LT.RAD2) THEN + CENTCYL = PT1 + ELSE + CENTCYL = PT2 + ENDIF + ELSE + HCYL = DEL1+DEL2-D + RCYL = SQRT(DEL1**2 - ((DEL1**2-DEL2**2+D**2)/(2*D))**2) + AXCYL = DIFF/D + CENTCYL = PT1+(DEL1-DEL2+D)/2*AXCYL + ENDIF + + END SUBROUTINE ENVELOPECYLINDER + + SUBROUTINE ADDBEAD(CHAINP,BEAD,DELE) + ! add an additional bead after the specified BEAD (cannot be last one) + ! returns consequent change in energy + + USE GENUTIL + USE CHAINUTIL, ONLY : GETBEADENERGY, OUTPUTSNAPSHOT, GETSTERICENERGY + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: BEAD + DOUBLE PRECISION, INTENT(OUT) :: DELE + INTEGER, PARAMETER :: MAXNTRY = 1000000 + DOUBLE PRECISION :: ENEW(2), EPREV, INTERP(6) + INTEGER :: NPT, IND, TRY, B, FAILFINITEXT, NCLASH + DOUBLE PRECISION :: XAX(3), YAX(3), UVEC(3), POS(3), UREL(3) + DOUBLE PRECISION :: ST, RHO, PHI, R1, R2, R3,U, LOGU, ND, ND2 + DOUBLE PRECISION :: DEL, LP, EC, GAM, EPAR, EPH, ECHECK + DOUBLE PRECISION :: DU1(3), DU2(3), DPERP(3), DPAR, DVEC(3), DIFF(3) + LOGICAL :: CLASH + DOUBLE PRECISION :: R1P, R2P, R3P, CVAL, COEFF(4) + DOUBLE PRECISION :: DIFFPT(3), DIST, RAD1, RAD2, H1, H2, VOL1, VOL2, FRAC1 + DOUBLE PRECISION :: LOGV, XAX2(3), YAX2(3), TMP, TMPSCL, CONST1, CONST2, TMP2, RAD, R1S, R2S, R3S + LOGICAL :: SUCCESS + DOUBLE PRECISION :: THETA, AX(3), UVEC1(3), UVEC2(3), ROTMAT(3,3) + + CALL OUTPUTSNAPSHOT(CHAINP,'startaddbead.out',0,.false.) + + IF (CHAINP%NPT.GE.CHAINP%MAXNPT) THEN + PRINT*, 'ERROR IN ADDBEAD: cannot add new bead because too many beads', CHAINP%NPT, CHAINP%MAXNPT + STOP 1 + ENDIF + + IF (.NOT.PARAMDATASET) THEN + PRINT*, 'ERROR IN ADDBEAD: parameter data array has not been set.' + STOP 1 + ENDIF + + IF (BEAD.LE.0.OR.BEAD.GE.CHAINP%NPT) THEN + PRINT*, 'ERROR IN ADDBEAD: cannot add after edge bead', BEAD + STOP 1 + ENDIF + + du1 = chainp%pos(:,bead+1)-chainp%pos(:,bead) + !print*, 'testx1:', bead, chainp%ls(bead), chainp%gam(bead), sqrt(dot_product(du1,du1)) + + EPREV = CHAINP%BEADENERGY(BEAD+1)+CHAINP%STERICENERGY + + + ! add bead to chain arrays (only those used for MC, not COORDS) + NPT = CHAINP%NPT + CHAINP%POS(:,BEAD+2:NPT+1) = CHAINP%POS(:,BEAD+1:NPT) + CHAINP%UVEC(:,BEAD+2:NPT+1) = CHAINP%UVEC(:,BEAD+1:NPT) + CHAINP%BEADENERGY(BEAD+2:NPT+1) = CHAINP%BEADENERGY(BEAD+1:NPT) + CHAINP%LS(BEAD+2:NPT) = CHAINP%LS(BEAD+1:NPT-1) + CHAINP%LP(BEAD+2:NPT) = CHAINP%LP(BEAD+1:NPT-1) + CHAINP%GAM(BEAD+2:NPT) = CHAINP%GAM(BEAD+1:NPT-1) + CHAINP%EPAR(BEAD+2:NPT) = CHAINP%EPAR(BEAD+1:NPT-1) + CHAINP%EPERP(BEAD+2:NPT) = CHAINP%EPERP(BEAD+1:NPT-1) + CHAINP%EC(BEAD+2:NPT) = CHAINP%EC(BEAD+1:NPT-1) + + CHAINP%NPT = CHAINP%NPT + 1 + + + ! reset the parameters + CHAINP%LS(BEAD) = CHAINP%LS(BEAD)/2 + CHAINP%LS(BEAD+1) = CHAINP%LS(BEAD) + + CALL INTERPARRAY(PARAMDATA,(/NPARAMDATA,6/),1,CHAINP%LS(BEAD),IND,INTERP) + IF (IND.LE.0.OR.IND.GE.NPARAMDATA) THEN + PRINT*, 'ERROR IN ADDBEAD: segment length is out of bounds', CHAINP%LS(BEAD), PARAMDATA(1,1),PARAMDATA(NPARAMDATA,1) + STOP 1 + ENDIF + + CHAINP%LP(BEAD:BEAD+1) = INTERP(2) + CHAINP%GAM(BEAD:BEAD+1) = INTERP(3) + CHAINP%EPAR(BEAD:BEAD+1) = INTERP(4) + CHAINP%EPERP(BEAD:BEAD+1) = INTERP(5) + CHAINP%EC(BEAD:BEAD+1) = INTERP(6) + +! ----------------------------------------------------- +! +! ! Rejection sampling to place bead with proper distribution +! DEL = CHAINP%LS(BEAD); GAM = CHAINP%GAM(BEAD); +! EPAR = CHAINP%EPAR(BEAD) +! EPH = CHAINP%EPERP(BEAD)-CHAINP%EC(BEAD)**2/CHAINP%LP(BEAD) +! LP = CHAINP%LP(BEAD) +! ! M = SQRT(2*PI*DEL)**3/EPAR/EPERP**2 +! ! LOGM = LOG(M); + +! IF (CHAINP%UVEC(1,BEAD)**2 + CHAINP%UVEC(2,BEAD)**2.EQ.0) THEN +! XAX = (/1D0,0D0,0D0/) +! YAX = (/0D0,1D0,0D0/) +! ELSE +! CALL CROSS_PRODUCT(CHAINP%UVEC(:,BEAD),(/0D0,0D0,1D0/),XAX) +! CALL NORMALIZE(XAX) +! CALL CROSS_PRODUCT(CHAINP%UVEC(:,BEAD),XAX,YAX) +! ENDIF + +! ! upper bead in coordinate system of lower bead +! DIFFPT = CHAINP%POS(:,BEAD+2)-CHAINP%POS(:,BEAD) +! !R3P = DOT_PRODUCT(DIFF,CHAINP%UVEC(:,BEAD)) +! !R1P = DOT_PRODUCT(DIFF,XAX) +! !R2P = DOT_PRODUCT(DIFF,YAX) +! !CVAL = (R1P**2/4 + R2P**2/4)/(2*DEL/EPH) + (R3P-DEL*GAM)**2/4/(2*DEL/EPAR) + +! RAD1 = DEL; RAD2 = DEL +! DIST = SQRT(DOT_PRODUCT(DIFFPT,DIFFPT)) +! IF (DIST.GT.RAD1+RAD2) THEN +! PRINT*, 'ERROR IN BEAD SAMPLING: beads too far apart', dist, rad1+rad2 +! stop 1 +! ENDIF + + +! ! heights of spherical caps +! H1 = (RAD2-RAD1+DIST)*(RAD2+RAD1-DIST)/(2*DIST) +! H2 = (RAD1-RAD2+DIST)*(RAD1+RAD2-DIST)/(2*DIST) +! VOL1 = H1**2*(3*RAD1-H1) ! 3/pi times the volume of the cap +! VOL2 = H2**2*(3*RAD2-H2) +! LOGV = LOG(VOL1+VOL2) +! FRAC1 = VOL1/(VOL1+VOL2) +! CONST1 = -RAD1**2*(RAD1-H1)+(RAD1-H1)**3/3D0 +! CONST2 = -RAD2**2*(RAD2-H2)+(RAD2-H2)**3/3D0 + +! CALL CROSS_PRODUCT(YAX,DIFFPT,XAX2); CALL NORMALIZE(XAX2) +! CALL CROSS_PRODUCT(DIFFPT,XAX2,YAX2); CALL NORMALIZE(YAX2) + +! FAILFINITEXT = 0; NCLASH = 0 +! DO TRY = 1,MAXNTRY +! !sample from envelope distrib +! U = GRND(); LOGU = LOG(U) +! PHI = GRND()*2*PI +! RHO = 1D0-ABS(SQRT(DEL/LP)*RNORM()) + +! IF (RHO.LT.-1D0) then +! !print*, 'testx-1:', try, rho +! CYCLE +! endif +! ST = SQRT(1-RHO**2) +! PHI = GRND()*2*PI + +! ! uniformly sample from intersection of 2 spheres for possible +! ! center bead position + +! ! sample position along axis and circle radius +! TMP = GRND(); TMP2 = GRND() +! IF (TMP.LT.FRAC1) THEN +! TMPSCL = TMP/FRAC1 +! COEFF = (/-1D0/3D0,0D0,RAD1**2, CONST1-H1**2*(3*RAD1-H1)/3*TMPSCL/) +! CALL CUBICROOT(COEFF,(/RAD1-H1,RAD1/),R3S,SUCCESS) + +! RAD = SQRT(RAD1**2 - R3S**2)*SQRT(TMP2) +! ELSE +! TMPSCL = (TMP-FRAC1)/(1-FRAC1) +! COEFF = (/-1D0/3D0,0D0,RAD2**2, CONST2-H2**2*(3*RAD2-H2)/3*TMPSCL/) +! CALL CUBICROOT(COEFF,(/RAD2-H2,RAD2/),R3S,SUCCESS) +! RAD = SQRT(RAD2**2 - R3S**2)*SQRT(TMP2) + +! R3S = DIST - R3S +! ENDIF +! IF (.NOT.SUCCESS) THEN +! PRINT*, 'ERROR IN BEAD SAMPLING: no cubic root found', TMP, FRAC1, tmpscl, R3S, RAD1, H1, TMPSCL +! print*, COEFF +! print*, rad2, h2, const2 +! STOP 1 +! ENDIF + +! THETA = GRND()*2*PI +! R1S = RAD*COS(THETA); R2S = RAD*SIN(THETA) + +! !R1 = SQRT(DEL/EPH)*RNORM() +! !R2 = SQRT(DEL/EPH)*RNORM() +! !R3 = SQRT(DEL/EPAR)*RNORM()+GAM*DEL +! !R1 = SQRT(2*DEL/EPH)*RNORM()+R1P/2 +! !R2 = SQRT(2*DEL/EPH)*RNORM()+R2P/2 +! !R3 = SQRT(2*DEL/EPAR)*RNORM()+R3P/2 + +! !IF (BEAD.EQ.4.AND.ABS(DEL-1).LT.1E-12) THEN +! ! PRINT*, 'testx5:', (R1-R1P/2)**2 + (R2-R2P/2)**2 + (R3-R3P/2)**2, 2*DEL/EPH, 2*DEL/EPAR +! !ENDIF + +! !POS = CHAINP%POS(:,BEAD) + R3*CHAINP%UVEC(:,BEAD)+R1*XAX+R2*YAX +! POS = R3S*DIFFPT/DIST + R1S*XAX2 + R2S*YAX2 +! R1 = DOT_PRODUCT(POS,XAX) +! R2 = DOT_PRODUCT(POS,YAX) +! R3 = DOT_PRODUCT(POS,CHAINP%UVEC(:,BEAD)) + +! POS = CHAINP%POS(:,BEAD)+POS + +! DVEC = CHAINP%POS(:,BEAD+2)-POS +! ND2 = DOT_PRODUCT(DVEC,DVEC); ND = SQRT(ND2); + +! ! Check for finite extension +! IF (CHAINP%FINITEXT) THEN +! IF (R1S**2+R2S**2+R3S**2.GT.DEL**2.OR.ND2.GT.DEL**2) THEN +! FAILFINITEXT = FAILFINITEXT+1 +! ! print*, 'testx0', try, R1S**2+R2S**2+R3S**2,ND2 +! !stop 1 +! CYCLE +! ENDIF +! ENDIF + +! ! u vector relative to previous one +! UrEl = (/ST*COS(PHI),ST*SIN(PHI),RHO/) +! DU1 = UREL + (/EC/LP*R1,EC/LP*R2,-1D0/) + +! ! absolute u vector +! UVEC = UREL(1)*XAX + UREL(2)*YAX + UREL(3)*CHAINP%UVEC(:,BEAD) +! !UVEC = DOT_PRODUCT(UREL,XAX)*XAX + DOT_PRODUCT(UREL,YAX)*YAX + & +! ! & DOT_PRODUCT(UREL,CHAINP%UVEC(:,BEAD))*CHAINP%UVEC(:,BEAD) +! DPAR = DOT_PRODUCT(DVEC,UVEC) +! DPERP = DVEC - DPAR*UVEC +! DU2 = CHAINP%UVEC(:,BEAD+2) - UVEC + EC/LP*DPERP + +! ECHECK = -LP/2/DEL*DOT_PRODUCT(DU1,DU1) - LP/2/DEL*DOT_PRODUCT(DU2,DU2)& +! & - EPAR/2/DEL*(DPAR-GAM*DEL)**2 - EPH/2/DEL*(ND2 - DPAR*DPAR) & +! & - EPAR/2/DEL*(R3-GAM*DEL)**2 - EPH/2/DEL*(R1**2+R2**2) & +! & - LOGV + +! ! IF (BEAD.EQ.3) THEN +! ! print*, 'TESTX1:', TRY, R1,R2,R3,RHO,ECHECK,LOGU +! ! PRINT*, 'TESTX2:', -LP/2/DEL*DOT_PRODUCT(DU1,DU1), - LP/2/DEL*DOT_PRODUCT(DU2,DU2) +! ! PRINT*, 'TESTX3:', - EPAR/2/DEL*(DPAR-GAM*DEL)**2, & +! ! & - EPH/2/DEL*(ND2 - DPAR*DPAR), - EPAR/2/DEL*(R3-GAM*DEL)**2, & +! ! & - EPH/2/DEL*(R1**2+R2**2), logv +! ! ENDIF + +! !IF (LOGU.GT.ECHECK) CYCLE + +! ! check for steric clashes with existing beads +! CLASH = .FALSE. +! ! IF (CHAINP%STERICS) THEN +! ! DO B = 1,CHAINP%NPT +! ! IF (ABS(B-BEAD+1).LT.CHAINP%STERSKIP) CYCLE +! ! DIFF = CHAINP%POS(:,B)-POS +! ! ND2 = DOT_PRODUCT(DIFF,DIFF) +! ! IF (ND2.LT.CHAINP%STERRAD2) THEN +! ! NCLASH = NCLASH + 1 +! ! CLASH = .TRUE.; EXIT +! ! ENDIF +! ! ENDDO +! ! ENDIF +! IF (.NOT.CLASH) EXIT + +! ENDDO +! IF (TRY.GE.MAXNTRY) THEN +! PRINT*, 'ERROR IN SAMPLING BEAD POSITION! Failed to generate successfull sample.', BEAD, DEL +! PRINT*, 'FRACTION OF TIME FAILED FINITE EXTENSION:', DBLE(FAILFINITEXT)/MAXNTRY +! PRINT*, 'FRACTION OF TIME FAILED CLASH:', DBLE(NCLASH)/MAXNTRY +! CALL OUTPUTSNAPSHOT(CHAINP,'fail.snap.out',0,.FALSE.) +! !STOP 1 +! ENDIF + +! CHAINP%POS(:,BEAD+1) = POS +! CHAINP%UVEC(:,BEAD+1) = UVEC + +! ! PRINT*, 'TESTX0:', CLASH, TRY +! CALL MINIMONTECARLO(CHAINP,BEAD+1,1000) +! ------------------------------- + + ! interpolate bead position + CHAINP%POS(:,BEAD+1) = (CHAINP%POS(:,BEAD) + CHAINP%POS(:,BEAD+2))/2 + + ! interpolate orientation (rotate halfway from one UVEC to the other + UVEC1 = CHAINP%UVEC(:,BEAD) + UVEC2 = CHAINP%UVEC(:,BEAD+2) + CALL CROSS_PRODUCT(UVEC1,UVEC2,AX) + CALL NORMALIZE(AX) + THETA = ACOS(DOT_PRODUCT(UVEC1,UVEC2)) + CALL ROTANGAX(THETA/2,AX,UVEC1,CHAINP%UVEC(:,BEAD+1),.TRUE.,ROTMAT) + +! CALL MINIMONTECARLO(CHAINP,BEAD+1,1000) + + ! recalculate energy for affected beads + !EPREV = CHAINP%BEADENERGY(BEAD+1) + CALL GETBEADENERGY(CHAINP,BEAD+1,ENEW(1)) + CALL GETBEADENERGY(CHAINP,BEAD+2,ENEW(2)) + CALL GETSTERICENERGY(CHAINP,CHAINP%STERICENERGY) + + DELE = ENEW(1)+ENEW(2)+CHAINP%STERICENERGY-EPREV-CHAINP%MU + + END SUBROUTINE ADDBEAD + + SUBROUTINE REMOVEBEAD(CHAINP,BEAD,DELE) + ! coarsen the discretization by removing one bead from the chain + ! cannot be an edge bead + ! returns consequent change in energy + USE GENUTIL, ONLY : INTERPARRAY + USE CHAINUTIL, ONLY : GETBEADENERGY + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: BEAD + DOUBLE PRECISION, INTENT(OUT) :: DELE + DOUBLE PRECISION :: ENEW, EPREV, INTERP(6),TMP,DIFF(3) + INTEGER :: NPT, IND + + + IF (.NOT.PARAMDATASET) THEN + PRINT*, 'ERROR IN REMOVE BEAD: parameter data array has not been set.' + STOP 1 + ENDIF + + IF (BEAD.LE.1.OR.BEAD.GE.CHAINP%NPT) THEN + PRINT*, 'ERROR IN REMOVEBEAD: cannot remove edge bead', BEAD + STOP 1 + ENDIF + + CALL GETBEADENERGY(CHAINP,BEAD,TMP) + IF (TMP.GT.1D10) THEN + DIFF = CHAINP%POS(:,BEAD)-CHAINP%POS(:,BEAD-1) + PRINT*, 'TESTX2:', BEAD,SQRT(DOT_PRODUCT(DIFF,DIFF)), CHAINP%LS(BEAD) + STOP 1 + ENDIF + + ! remove bead from chain arrays (only those used for MC, not COORDS) + NPT = CHAINP%NPT + CHAINP%POS(:,BEAD:NPT-1) = CHAINP%POS(:,BEAD+1:NPT) + CHAINP%UVEC(:,BEAD:NPT-1) = CHAINP%UVEC(:,BEAD+1:NPT) + + !PRINT*, 'TESTX1:', TMP,CHAINP%BEADENERGY(BEAD), CHAINP%BEADENERGY(BEAD+1) + EPREV = CHAINP%BEADENERGY(BEAD)+CHAINP%BEADENERGY(BEAD+1) + CHAINP%BEADENERGY(BEAD:NPT-1) = CHAINP%BEADENERGY(BEAD+1:NPT) + + CHAINP%LS(BEAD-1) = CHAINP%LS(BEAD-1)+CHAINP%LS(BEAD) + + CHAINP%LS(BEAD:NPT-2) = CHAINP%LS(BEAD+1:NPT-1) + CHAINP%LP(BEAD:NPT-2) = CHAINP%LP(BEAD+1:NPT-1) + CHAINP%GAM(BEAD:NPT-2) = CHAINP%GAM(BEAD+1:NPT-1) + CHAINP%EPAR(BEAD:NPT-2) = CHAINP%EPAR(BEAD+1:NPT-1) + CHAINP%EPERP(BEAD:NPT-2) = CHAINP%EPERP(BEAD+1:NPT-1) + CHAINP%EC(BEAD:NPT-2) = CHAINP%EC(BEAD+1:NPT-1) + + CHAINP%LS(NPT-1) = 0; CHAINP%LP(NPT-1) = 0; + CHAINP%GAM(NPT-1) = 0; CHAINP%EPAR(NPT-1) = 0; + CHAINP%EPERP(NPT-1) = 0; CHAINP%EC(NPT-1) = 0; + CHAINP%BEADENERGY(NPT) = 0 + + ! decrease number of beads + CHAINP%NPT = NPT-1 + + ! get new parameters + CALL INTERPARRAY(PARAMDATA,(/NPARAMDATA,6/),1,CHAINP%LS(BEAD-1),IND,INTERP) + IF (IND.LE.0.OR.IND.GE.NPARAMDATA) THEN + PRINT*, 'ERROR IN REMOVEBEAD: segment length is out of bounds', CHAINP%LS(BEAD-1), PARAMDATA(1,1),PARAMDATA(NPARAMDATA,1) + STOP 1 + ENDIF + + CHAINP%LP(BEAD-1) = INTERP(2) + CHAINP%GAM(BEAD-1) = INTERP(3) + CHAINP%EPAR(BEAD-1) = INTERP(4) + CHAINP%EPERP(BEAD-1) = INTERP(5) + CHAINP%EC(BEAD-1) = INTERP(6) + + ! recalculate energy for affected bead + CALL GETBEADENERGY(CHAINP,BEAD,ENEW) + DELE = ENEW-EPREV+CHAINP%MU + !PRINT*, 'TESTX2:', ENEW,EPREV,CHAINP%MU + ! IF (DELE.LT.-1E10) THEN + ! PRINT*, DELE, BEAD, EPREV, ENEW + ! STOP 2 + ! ENDIF + END SUBROUTINE REMOVEBEAD + + SUBROUTINE READPARAMDATA(INFILE) + ! read in a file containing parameter data + ! columns in order: del, lp, gam, epar, eperp, ec, plen, err + ! first 6 columns are saved into global array PARAMDATA + + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: INFILE + DOUBLE PRECISION :: DATAROW(8), TMP1, TMP2 + INTEGER :: C, NROW, ICHECK + + ! find number of lines in the file + OPEN(UNIT=88,FILE=INFILE,STATUS='OLD') + NROW = 0 + DO + READ(88,*,IOSTAT=ICHECK) DATAROW + IF (ICHECK.LT.0) EXIT + NROW = NROW + 1 + ENDDO + NPARAMDATA = NROW + + ALLOCATE(PARAMDATA(NROW,6)) + PARAMDATASET = .TRUE. + + REWIND(88) + + DO C = 1,NROW + READ(88,*,IOSTAT=ICHECK) PARAMDATA(C,:),TMP1,TMP2 + ENDDO + END SUBROUTINE READPARAMDATA + + SUBROUTINE CLEANUPDATA + DEALLOCATE(PARAMDATA) + END SUBROUTINE CLEANUPDATA + + SUBROUTINE CUBICROOT(COEFF,RANGE,ROOT, SUCCESS) + ! for a cubic equation Ax^3 + Bx^2 + Cx + D + ! return the real root within range RANGE if one exists + ! otherwise SUCCESS=.false. + USE GENUTIL, ONLY : PI + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: COEFF(4),RANGE(2) + DOUBLE PRECISION, INTENT(OUT) :: ROOT + LOGICAL, INTENT(OUT) :: SUCCESS + DOUBLE PRECISION :: A,B,C + DOUBLE PRECISION :: Q, R, SQ, THETA, AVAL, BVAL + + A = COEFF(2)/COEFF(1) + B = COEFF(3)/COEFF(1) + C = COEFF(4)/COEFF(1) + + ! algorithm from numerical recipes + Q = (A**2 - 3*B)/9; + R = (2*A**3 - 9*A*B + 27*c)/54 + + IF (R**2.LT.Q**3) THEN +! print*, 'testx1' + ! three real roots + SQ = SQRT(Q) + THETA = ACOS(R/SQ**3) + SUCCESS = .TRUE. + ROOT = -2*SQ*COS(THETA/3)-A/3 + IF (ROOT.GE.RANGE(1).AND.ROOT.LE.RANGE(2)) RETURN + ROOT = -2*SQ*COS((THETA+2*PI)/3) - A/3 + IF (ROOT.GE.RANGE(1).AND.ROOT.LE.RANGE(2)) RETURN + ROOT = -2*SQ*COS((THETA-2*PI)/3) - A/3 + IF (ROOT.GE.RANGE(1).AND.ROOT.LE.RANGE(2)) RETURN + SUCCESS = .FALSE. + ELSE + ! print*, 'testx2' + AVAL = -SIGN(1D0,R)*(ABS(R) + SQRT(R**2-Q**3))**(1D0/3D0) + IF (AVAL.EQ.0) THEN + BVAL=0 + ELSE + BVAL = Q/AVAL + ENDIF + ROOT = (AVAL+BVAL) - A/3 + IF (ROOT.GE.RANGE(1).AND.ROOT.LE.RANGE(2)) THEN + SUCCESS = .TRUE. + ELSE + SUCCESS = .FALSE. + ENDIF + ENDIF + END SUBROUTINE CUBICROOT + + SUBROUTINE MINIMONTECARLO(CHAINP,BEAD,NSTEPS) + ! run a short monte carlo to equilibrate a particular new bead + USE MT19937, ONLY : GRND + USE CHAINUTIL, ONLY : GETBEADENERGY, GETFORCEENERGY + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: BEAD, NSTEPS +! DOUBLE PRECISION, INTENT(FINAL) :: DELEFINAL + DOUBLE PRECISION :: STARTENERGY, PREVENERGIES(2), PREVPOS(3), PREVUVEC(3), DELE + INTEGER :: STEP + LOGICAL :: ACCEPT, STARTCLASH + DOUBLE PRECISION :: ARANGE, RRANGE, TMP + + ARANGE = 0.1D0 + RRANGE = CHAINP%LS(BEAD)/10 + + IF (BEAD.EQ.CHAINP%NPT) THEN + PRINT*, 'ERROR IN MINIMONTECARLO: not set up for edge bead' + STOP 1 + ENDIF + + STARTCLASH = .FALSE. + CALL BEADMOVE3(CHAINP,0D0,0D0,BEAD,DELE) + STARTENERGY = CHAINP%BEADENERGY(BEAD)+CHAINP%BEADENERGY(BEAD+1)+CHAINP%FORCEENERGY+CHAINP%STERICENERGY + + !CALL GETBEADENERGY(CHAINP,BEAD,CHAINP%BEADENERGY(BEAD)) + !CALL GETBEADENERGY(CHAINP,BEAD+1,CHAINP%BEADENERGY(BEAD+1)) + !CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY) + !STARTENERGY = CHAINP%BEADENERGY(BEAD)+CHAINP%BEADENERGY(BEAD+1)+CHAINP%FORCEENERGY + PREVENERGIES = CHAINP%BEADENERGY(BEAD:BEAD+1) + PREVPOS = CHAINP%POS(:,BEAD) + PREVUVEC = CHAINP%UVEC(:,BEAD) + + DO STEP = 1,NSTEPS + CALL BEADMOVE3(CHAINP,ARANGE,RRANGE,BEAD,DELE) + + IF (DELE.LT.0) THEN + ACCEPT = .TRUE. + ELSE + TMP = GRND() + ACCEPT = (TMP.LT.EXP(-DELE)) + ENDIF + + ! IF (STARTCLASH) THEN + ! ACCEPT = .TRUE. + ! IF (DELE.LT.HUGE(1D0)) STARTCLASH = .FALSE. + ! ENDIF + + IF (ACCEPT) THEN + PREVENERGIES = CHAINP%BEADENERGY(BEAD:BEAD+1) + PREVPOS = CHAINP%POS(:,BEAD) + PREVUVEC = CHAINP%UVEC(:,BEAD) + ELSE + CHAINP%BEADENERGY(BEAD:BEAD+1) = PREVENERGIES + CHAINP%POS(:,BEAD) = PREVPOS + CHAINP%UVEC(:,BEAD) = PREVUVEC + ENDIF + + ! IF (MOD(STEP,100).EQ.0) THEN + ! print*, 'step, energy:', STEP, CHAINP%BEADENERGY(BEAD)+CHAINP%BEADENERGY(BEAD+1), dele, accept + ! ENDIF + ENDDO + + END SUBROUTINE MINIMONTECARLO + + SUBROUTINE BEADMOVE3(CHAINP,ARANGE,RRANGE,B,DELE) + ! move and rotate an individual bead + USE MT19937, ONLY : GRND + USE CHAINUTIL, ONLY : GETSTERICENERGY, GETBEADENERGY, GETFORCEENERGY, CHAIN + USE QUAtUTIL, ONLY : ROTANGAX + IMPLICIT NONE + + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION, INTENT(IN) :: ARANGE, RRANGE + INTEGER, INTENT(in) :: B + DOUBLE PRECISION, INTENT(OUT) :: DELE + DOUBLE PRECISION :: AX(3), ANG, DELR(3), PREVE, TMP(3),ROTMAT(3,3) + INTEGER :: I, ALLBEADS(CHAINP%NPT), B2 + LOGICAL :: CLASH + DOUBLE PRECISION :: DIFF(3), ND2 + + ! get a random bead + !B = FLOOR(GRND()*CHAINP%NPT)+1 + + ! get a random axis + DO I = 1,3 + AX(I) = GRND() + ENDDO + AX = AX/SQRT(DOT_PRODUCT(AX,AX)) + + ! get a random angle + ANG = GRND()*2*ARANGE-ARANGE + + ! get a random shift + IF (CHAINP%STRETCHABLE.AND.CHAINP%SHEARABLE) THEN + DO I = 1,3 + DELR(I) = GRND()*2*RRANGE - RRANGE + ENDDO + ELSEIF (CHAINP%STRETCHABLE.AND..NOT.CHAINP%SHEARABLE) THEN + PRINT*, 'STRETCHABLE AND NOT SHEARABLE NOT YET SET UP' + STOP 2 + ELSEIF (CHAINP%SHEARABLE.AND..NOT.CHAINP%STRETCHABLE) THEN + PRINT*, 'SHEARABLE AND NOT STRETCHABLE NOT YET SET UP' + STOP 2 + ELSE + DELR = 0D0 + ENDIF + + ! rotate selected bead + CALL ROTANGAX(ANG,AX,CHAINP%UVEC(:,B),TMP,.TRUE.,ROTMAT) + CHAINP%UVEC(:,B) = TMP + ! shift selected bead + CHAINP%POS(:,B) = CHAINP%POS(:,B) + DELR + + ! update bordering energies + IF (B.EQ.1) THEN + PREVE = CHAINP%BEADENERGY(B+1)+CHAINP%FORCEENERGY+CHAINP%STERICENERGY + CALL GETBEADENERGY(CHAINP,B+1,CHAINP%BEADENERGY(B+1)) + CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY) + DELE = CHAINP%BEADENERGY(B+1)+CHAINP%FORCEENERGY-PREVE + ELSEIF (B.EQ.CHAINP%NPT) THEN + PREVE = CHAINP%BEADENERGY(B)+CHAINP%FORCEENERGY+CHAINP%STERICENERGY + CALL GETBEADENERGY(CHAINP,B,CHAINP%BEADENERGY(B)) + CALL GETFORCEENERGY(CHAINP,CHAINP%FORCEENERGY) + DELE = CHAINP%BEADENERGY(B)+CHAINP%FORCEENERGY-PREVE + ELSE + PREVE = CHAINP%BEADENERGY(B+1) + CHAINP%BEADENERGY(B)+CHAINP%STERICENERGY + CALL GETBEADENERGY(CHAINP,B,CHAINP%BEADENERGY(B)) + CALL GETBEADENERGY(CHAINP,B+1,CHAINP%BEADENERGY(B+1)) + DELE = CHAINP%BEADENERGY(B+1) + CHAINP%BEADENERGY(B) - PREVE + ENDIF + + IF (CHAINP%STERICS) CALL GETSTERICENERGY(CHAINP,CHAINP%STERICENERGY) + DELE = DELE + CHAINP%STERICENERGY + +! THEN +! DO B2 = 1,CHAINP%NPT +! IF (ABS(B2-B).Le.CHAINP%STERSKIP) CYCLE +! DIFF = CHAINP%POS(:,B)-CHAINP%POS(:,B2) +! ND2 = DOT_PRODUCT(DIFF,DIFF) +! IF (ND2.LT.CHAINP%STERRAD2) THEN +! DELE = HUGE(1D0) +! RETURN +! ENDIF +! ENDDO +! ENDIF + + ! IF (CHAINP%STERICS) THEN + ! ALLBEADS = (/(I, I=1,CHAINP%NPT)/) + ! CALL CHECKSTERICCLASH(CHAINP,1,(/B/),CHAINP%NPT,ALLBEADS,CLASH) + ! IF (CLASH) THEN + ! DELE = HUGE(1D0) + ! RETURN + ! ENDIF + ! ENDIF + + ! IF (DELE.GT.HUGE(1D0)/100) THEN + ! PRINT*, 'BAD DELE IN BEADMOVE3:', DELE, CHAINP%BEADENERGY(B), CHAINP%BEADENERGY(B+1) + ! STOP 1 + ! ENDIF + END SUBROUTINE BEADMOVE3 +END MODULE REDISC diff --git a/BasicWLC/dssWLC/source/sampleutil.f90 b/BasicWLC/dssWLC/source/sampleutil.f90 new file mode 100644 index 00000000..e275ad81 --- /dev/null +++ b/BasicWLC/dssWLC/source/sampleutil.f90 @@ -0,0 +1,874 @@ +MODULE SAMPLEUTIL + ! Utilities for sampling from various distributions, + ! including rejection sampling for segment joints of the dssWLC + USE MT19937, ONLY : GRND, RNORM,MVNORM + use QUATUTIL, ONLY : PI + + IMPLICIT NONE + +CONTAINS + SUBROUTINE GETEQUILCHAIN(CHAINP,TYPESAMPLE,LASTCOORDS,STARTCOORDS) + ! sample a configuration of the chain from the equilibrium free distribution + ! uses rejection sampling for the coupled coordinates + ! should be exact for any segment length (no gaussian approximations + ! TYPESAMPLE is the type of sampling to do: + ! 1) old version of rejection sampling (better for very flexible chains) + ! 2) multivariate normal version of rejection sampling (better for very stiff/short segments) + ! 3) monte carlo sampling + ! LASTCOORDS: if doing monte carlo returns last coordinate and range values + ! if STARTCOORDS is supplied (and using MC) then use the given starting + ! coordinates and step ranges, without an initialization period + + USE CHAINUTIL, ONLY : CHAIN + USE GENUTIL, ONLY : CROSS_PRODUCT, NORMALIZE + USE KEYS, ONLY : MCSTATSTEPS, MCINITSTEPS, GAUSSIANCHAIN, LOGRTERM, NEDGESEG + + IMPLICIT NONE + TYPE(CHAIN), POINTER :: CHAINP + INTEGER, INTENT(IN) :: TYPESAMPLE + DOUBLE PRECISION, INTENT(OUT) :: LASTCOORDS(6) + DOUBLE PRECISION, INTENT(IN), OPTIONAL :: STARTCOORDS(6) + DOUBLE PRECISION :: COORDS(4,CHAINP%NPT-1), Z, R, RHO, PHI, ST, PHIPERP,PHIU + DOUBLE PRECISION :: DEL(CHAINP%NPT), ETA(CHAINP%NPT) + INTEGER :: BC + DOUBLE PRECISION :: XAX(3), YAX(3), FINALRANGES(3) + + IF (TYPESAMPLE.LT.1.OR.TYPESAMPLE.GT.3) THEN + PRINT*, 'INVALID VALUE OF TYPESAMPLE', TYPESAMPLE + STOP 1 + ENDIF + + CHAINP%POS(:,1) = (/0D0,0D0,0D0/) + ! place first orientation vector uniformly + RHO = GRND()*2-1; ST = SQRT(1-RHO**2) + PHI = GRND()*2*PI + CHAINP%UVEC(:,1) = (/ST*COS(PHI),ST*SIN(PHI),RHO/) + + ! Get relative coordinates for each bead (relative to previous one) + ! coordinates are (in order): + ! z = translation along uvec + ! r = magnitude translation perpendicular to uvec + ! rho = cos(angle between subsequent uvecs) + ! phi = angle between the perp translation and the subsequent uvec + + DEL = CHAINP%LS + ETA = -CHAINP%EC/CHAINP%LP + IF (TYPESAMPLE.EQ.3) THEN + IF (NEDGESEG.GT.0) THEN + PRINT*, 'MONTE CARLO INITIAL SAMPLING NOT YET SET UP WITH DIFFERENT EDGE SEGMENTS!' + STOP 1 + ENDIF + !monte carlo sampling + IF (PRESENT(STARTCOORDS)) THEN + CALL SAMPLERELCOORDSMC(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),CHAINP%NPT-1,& + & MCSTATSTEPS,0,COORDS,FINALRANGES,STARTCOORDS) + ELSE + CALL SAMPLERELCOORDSMC(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),CHAINP%NPT-1,& + & MCSTATSTEPS,MCINITSTEPS,COORDS,FINALRANGES) + ENDIF + LASTCOORDS(1:3) = COORDS(2:4,CHAINP%NPT-1) + LASTCOORDS(4:6) = FINALRANGES + ELSE + IF (GAUSSIANCHAIN) THEN + ! plain old normal sampling for gaussian chain + IF (NEDGESEG.GT.0) THEN + CALL SAMPLERELCOORDSGAUSSIAN(DEL(1),CHAINP%EPAR(1),CHAINP%EPERP(1),NEDGESEG,COORDS(:,1:NEDGESEG)) + CALL SAMPLERELCOORDSGAUSSIAN(DEL(CHAINP%NPT-1),& + & CHAINP%EPAR(CHAINP%NPT-1),CHAINP%EPERP(CHAINP%NPT-1),& + & NEDGESEG,COORDS(:,CHAINP%NPT-NEDGESEG:CHAINP%NPT-1)) + CALL SAMPLERELCOORDSGAUSSIAN(DEL(NEDGESEG+1),& + & CHAINP%EPAR(NEDGESEG+1),CHAINP%EPERP(NEDGESEG+1),& + & CHAINP%NPT-1-2*NEDGESEG,COORDS(:,NEDGESEG+1:CHAINP%NPT-NEDGESEG-1)) + ELSE + CALL SAMPLERELCOORDSGAUSSIAN(DEL(1),CHAINP%EPAR(1),CHAINP%EPERP(1),CHAINP%NPT-1,COORDS) + ENDIF + + ELSE IF (CHAINP%SHEARABLE) THEN + ! use rejection sampling + IF (TYPESAMPLE.EQ.1) THEN + IF (NEDGESEG.GT.0) THEN + CALL SAMPLERELCOORDS(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),NEDGESEG,& + & COORDS(:,1:NEDGESEG),CHAINP%SHEARABLE) + CALL SAMPLERELCOORDS(DEL(CHAINP%NPT-1),CHAINP%LP(CHAINP%NPT-1),CHAINP%GAM(CHAINP%NPT-1),& + & CHAINP%EPAR(CHAINP%NPT-1),CHAINP%EPERP(CHAINP%NPT-1),ETA(CHAINP%NPT-1),NEDGESEG,& + & COORDS(:,CHAINP%NPT-NEDGESEG:CHAINP%NPT-1),CHAINP%SHEARABLE) + CALL SAMPLERELCOORDS(DEL(NEDGESEG+1),CHAINP%LP(NEDGESEG+1),CHAINP%GAM(NEDGESEG+1),& + & CHAINP%EPAR(NEDGESEG+1),CHAINP%EPERP(NEDGESEG+1),ETA(NEDGESEG+1),CHAINP%NPT-1-2*NEDGESEG,& + & COORDS(:,NEDGESEG+1:CHAINP%NPT-NEDGESEG-1),CHAINP%SHEARABLE) + ELSE + CALL SAMPLERELCOORDS(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),CHAINP%NPT-1,COORDS,CHAINP%SHEARABLE) + ENDIF + + ELSEIF (TYPESAMPLE.EQ.2) THEN + ! use multivariate normal rejection sampling + IF (NEDGESEG.GT.0) THEN + CALL SAMPLERELCOORDSMVN(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),NEDGESEG,& + & COORDS(:,1:NEDGESEG)) + CALL SAMPLERELCOORDSMVN(DEL(CHAINP%NPT-1),CHAINP%LP(CHAINP%NPT-1),CHAINP%GAM(CHAINP%NPT-1),& + & CHAINP%EPAR(CHAINP%NPT-1),CHAINP%EPERP(CHAINP%NPT-1),ETA(CHAINP%NPT-1),NEDGESEG,& + & COORDS(:,CHAINP%NPT-NEDGESEG:CHAINP%NPT-1)) + CALL SAMPLERELCOORDSMVN(DEL(NEDGESEG+1),CHAINP%LP(NEDGESEG+1),CHAINP%GAM(NEDGESEG+1),& + & CHAINP%EPAR(NEDGESEG+1),CHAINP%EPERP(NEDGESEG+1),ETA(NEDGESEG+1),CHAINP%NPT-1-2*NEDGESEG,& + & COORDS(:,NEDGESEG+1:CHAINP%NPT-NEDGESEG-1)) + ELSE + CALL SAMPLERELCOORDSMVN(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),CHAINP%NPT-1,COORDS) + ENDIF + ENDIF + ELSE + IF (LOGRTERM) THEN + IF (NEDGESEG.GT.0) THEN + CALL SAMPLERELCOORDS(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),NEDGESEG,& + & COORDS(:,1:NEDGESEG),CHAINP%SHEARABLE) + CALL SAMPLERELCOORDS(DEL(CHAINP%NPT-1),CHAINP%LP(CHAINP%NPT-1),CHAINP%GAM(CHAINP%NPT-1),& + & CHAINP%EPAR(CHAINP%NPT-1),CHAINP%EPERP(CHAINP%NPT-1),ETA(CHAINP%NPT-1),NEDGESEG,& + & COORDS(:,CHAINP%NPT-NEDGESEG:CHAINP%NPT-1),CHAINP%SHEARABLE) + CALL SAMPLERELCOORDS(DEL(NEDGESEG+1),CHAINP%LP(NEDGESEG+1),CHAINP%GAM(NEDGESEG+1),& + & CHAINP%EPAR(NEDGESEG+1),CHAINP%EPERP(NEDGESEG+1),ETA(NEDGESEG+1),CHAINP%NPT-1-2*NEDGESEG,& + & COORDS(:,NEDGESEG+1:CHAINP%NPT-NEDGESEG-1),CHAINP%SHEARABLE) + ELSE + CALL SAMPLERELCOORDS(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%EPERP(1),ETA(1),CHAINP%NPT-1,COORDS,CHAINP%SHEARABLE) + ENDIF + ELSE + IF (NEDGESEG.GT.0) THEN + CALL SAMPLERELCOORDSNOSHEAR(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),NEDGESEG,COORDS(:,1:NEDGESEG),CHAINP%STRETCHABLE) + CALL SAMPLERELCOORDSNOSHEAR(DEL(CHAINP%NPT-1),CHAINP%LP(CHAINP%NPT-1),CHAINP%GAM(CHAINP%NPT-1),& + & CHAINP%EPAR(CHAINP%NPT-1),NEDGESEG,COORDS(:,CHAINP%NPT-NEDGESEG:CHAINP%NPT-1),CHAINP%STRETCHABLE) + CALL SAMPLERELCOORDSNOSHEAR(DEL(NEDGESEG+1),CHAINP%LP(NEDGESEG+1),CHAINP%GAM(NEDGESEG+1),& + & CHAINP%EPAR(NEDGESEG+1),CHAINP%NPT-1-2*NEDGESEG,& + & COORDS(:,NEDGESEG+1:CHAINP%NPT-1-NEDGESEG),CHAINP%STRETCHABLE) + ELSE + CALL SAMPLERELCOORDSNOSHEAR(DEL(1),CHAINP%LP(1),CHAINP%GAM(1),& + & CHAINP%EPAR(1),CHAINP%NPT-1,COORDS,CHAINP%STRETCHABLE) + ENDIF + ENDIF + ENDIF + ENDIF + + DO BC = 2,CHAINP%NPT + Z = COORDS(1,BC-1); R = COORDS(2,BC-1); + RHO = COORDS(3,BC-1); PHI = COORDS(4,BC-1) + ST = SQRT(1-RHO**2) + + ! set up orthonormal triad for previous bead + IF (CHAINP%UVEC(2,BC-1)**2 + CHAINP%UVEC(3,BC-1)**2.EQ.0) THEN + YAX = (/0D0,0D0,1D0/) + XAX = (/0D0,1D0,0D0/) + ELSE + CALL CROSS_PRODUCT(CHAINP%UVEC(:,BC-1),(/1D0,0D0,0D0/),YAX) + CALL NORMALIZE(YAX) + CALL CROSS_PRODUCT(YAX,CHAINP%UVEC(:,BC-1),XAX) + CALL NORMALIZE(XAX) + ENDIF + + IF (CHAINP%SHEARABLE) THEN + ! pick orientation of perpendicular displacement randomly around uvec + PHIPERP = GRND()*2*PI + ! place bead + ! print*, 'testx1:', bc, z, r, rho, phi, sqrt(sum(chainp%uvec(:,bc-1)**2)) + CHAINP%POS(:,BC) = CHAINP%POS(:,BC-1) + Z*CHAINP%UVEC(:,BC-1) & + & + R*COS(PHIPERP)*XAX + R*SIN(PHIPERP)*YAX + ELSE + PHIPERP = 0D0 + CHAINP%POS(:,BC) = CHAINP%POS(:,BC-1) + Z*CHAINP%UVEC(:,BC-1) + ENDIF + + ! place next orientation vector + PHIU = PHIPERP+PHI + + CHAINP%UVEC(:,BC) = ST*COS(PHIU)*XAX + ST*SIN(PHIU)*YAX + RHO*CHAINP%UVEC(:,BC-1) + ENDDO + + END SUBROUTINE GETEQUILCHAIN + + SUBROUTINE A0BOUNDFUNC(R,PARAM,FU,DU) + ! function used to find enveloping Lorentzian for cylindrical gaussian + ! PARAM is array of parameters (A,B,R0,M0) + ! FU returns function values, DU returns derivative + ! sign flipped upside down to do minimization rather than maximization + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: R, PARAM(:) + DOUBLE PRECISION, INTENT(OUT) :: FU, DU + DOUBLE PRECISION :: A, B, R0, M0 + + A = PARAM(1); B = PARAM(2); R0 = PARAM(3); M0 = PARAM(4) + + + IF (ABS(R-R0).LT.1D-6) THEN + ! use asymptotic form near r0 + !DU = (-B+SQRT(2/A+B**2))/(6+3*A*B**2) + !FU = 1 + B*SQRT(A/(2+A*B**2))/(2*A) + DU*(R-R0) + DU = (-2*A*B-A**2*B**3+2*SQRT(A*(2+A*B**2))+B**2*SQRT(A**3*(2+A*B**2)))/(3*A*(2+A*B**2)**2) + FU = (2*A*B+A**2*B**3+2*SQRT(A*(2+A*B**2))+B**2*SQRT(A**3*(2+A*B**2)))/2/SQRT((A*(2+A*B**2))**3) + DU*(R-R0) + !PRINT*, 'TESTX3', DU + ELSE + DU = (R-R0)*(-2*R**2-EXP(A*(B-R)**2)*M0*(R*(-3-2*A*(B-R)*(R-R0))+R0)) / & + & (R-M0*EXP(A*(B-R)**2))**2 + FU = R*(R-R0)**2/(M0*EXP(A*(R-B)**2) - R) + END IF + + FU = -FU; DU = -DU; + + ! PRINT*, 'TESTX1:', R, PARAM, FU, DU + END SUBROUTINE A0BOUNDFUNC + + SUBROUTINE GETLORENTZENVELOPE(A,B,LORPARAM) + ! find an enveloping Lorenzian distribution + ! for the cylindrical normal P~r*exp(-a*(r-b)^2) + ! returns parameters: r0,m0,a0 + ! enveloping distribution g ~ m0/(1+(r-r0)^2/a0) + ! see 4/24/2013 notes + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: A,B + DOUBLE PRECISION, INTENT(OUT) :: LORPARAM(3) + DOUBLE PRECISION :: R0,M0,A0 + DOUBLE PRECISION :: FU, DU, PARAM(4) + DOUBLE PRECISION :: AX, BX, STEPSIZE, CX, FMIN, XMIN + ! minimization function + DOUBLE PRECISION :: DBRENT + EXTERNAL DBRENT + ! max number of steps to try when bracketing + INTEGER, PARAMETER :: MAXNSTEP = 100; + INTEGER :: C + + + ! position of maximum likelihood + R0 = B/2 + 0.5D0*SQRT(2/A+B**2) + ! maximum value (at r0) + M0 = R0*EXP(-A*(R0-B)**2) + + ! find an appropriate width of the Lorentzian such that it's always greater than our cylindrical Gaussian + ! WARNING: technically this finds a local rather than global minimum, though for this particular functional form it doesn't seem to be a problem + +! PRINT*, R0, M0 + + ! bracket the minimum + AX = 0D0 + BX = R0 + STEPSIZE = R0 + DO C = 1,MAXNSTEP + CX = R0+C*STEPSIZE + CALL A0BOUNDFUNC(CX,(/A,B,R0,M0/),FU,DU) + IF (FU.GT.-M0) THEN + EXIT + ENDIF + ENDDO + IF (C.GE.MAXNSTEP) THEN + PRINT*, 'ERROR IN SAMPLECYLNORMAL: failed to bracket extremum' + STOP 1 + ENDIF + + PARAM = (/A,B,R0,M0/) + + ! PRINT*, 'BRACKETS:' + ! CALL A0BOUNDFUNC(AX,PARAM,FU,DU) + ! PRINT*, AX, FU, DU + ! CALL A0BOUNDFUNC(BX,PARAM,FU,DU) + ! PRINT*, BX, FU, DU + ! CALL A0BOUNDFUNC(CX,PARAM,FU,DU) + ! PRINT*, CX, FU, DU + + FMIN = DBRENT(AX,BX,CX,A0BOUNDFUNC,4,PARAM,SQRT(EPSILON(1D0)),XMIN) + + ! PRINT*, 'MINIMUM:', XMIN, FMIN + A0 = -FMIN + + LORPARAM = (/R0,M0,A0/) + END SUBROUTINE GETLORENTZENVELOPE + + SUBROUTINE SAMPLECYLNORMAL(A,B,LORPARAM,RVAL,NTRY) + ! sample from a cylindrical normal distribution P ~ r exp(-a*(r-b)^2) for r>0 + ! uses rejection sampling with a Lorentzian (Cauchy) distribution envelope + ! defined by g ~ M0/(1+(r-r0)^2/a0) where lorparam = (r0,m0,a0) + ! get the enveloping distribution parameters using GETLORENTZENVELOPE + ! see 4/24/2013 notes + ! NTRY is the number of tries required to get an accepted sample + + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: A,B, LORPARAM(3) + DOUBLE PRECISION, INTENT(OUT) :: RVAL + INTEGER, INTENT(OUT) :: NTRY + DOUBLE PRECISION :: R0,M0,A0, R, U, U2, RATIO + INTEGER :: TRY + ! maximum number of rejection trials before giving up + INTEGER, PARAMETER :: MAXNTRY = 1000 + + R0 = LORPARAM(1); M0 = LORPARAM(2); A0 = LORPARAM(3); + !PRINT*, 'TESTX0:', R0, M0, A0 + DO TRY = 1,MAXNTRY + ! Sample R from the lorentzian + U = GRND() ! uniform variate + R = R0 - SQRT(A0)/TAN(PI*U) + !PRINT*, 'TESTX1:', U, PI*U, R + + ! uniform sample to decide whether to reject + U2 = GRND() + RATIO = R*EXP(-A*(R-B)**2)/(M0/(1+(R-R0)**2/A0)) + IF (U2.LT.RATIO) THEN + EXIT + ENDIF + ENDDO + + IF (TRY.GE.MAXNTRY) THEN + PRINT*, 'ERROR IN SAMPLECYLNORMAL: failed to generate successful trial' + STOP 1 + ENDIF + + RVAL = R; NTRY = TRY; + !PRINT*, R, TRY + END SUBROUTINE SAMPLECYLNORMAL + + SUBROUTINE SAMPLERRHOPHI(DEL,EB,EPERPH,ETA,R,RHO,PHI,NTRIAL) + ! rejection sampling for R,Rho, PHI coordinates + ! enveloping distribution is one with uniform phi + ! sample R and RHO from the enveloping distribution that is independent of PHI + ! EPERPH corresponds to eperp_hat in the notes, but EPERP in the code + ! ETA is -EC/LP in the simulation code and EB=LP + ! see notes from 4/24/2013 + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EB, EPERPH, ETA + DOUBLE PRECISION, INTENT(OUT) :: R, RHO, PHI + INTEGER, INTENT(OUT) :: NTRIAL + DOUBLE PRECISION :: A,B, C, U, LORPARAM(3) + INTEGER :: TRY, NTRYR + DOUBLE PRECISION :: SP, RATIO + ! maximum rejection trials before giving up + INTEGER, PARAMETER :: MAXNTRY = 1000 + + A = EPERPH/2/DEL + B = ETA*EB/EPERPH + C = EB/2/DEL + + CALL GETLORENTZENVELOPE(A,B,LORPARAM) + + DO TRY = 1,MAXNTRY + ! sample rho from a truncated exponential + U = GRND() + RHO = 1/C*LOG(EXP(-C)+2*U*SINH(C)) + + ! sample phi uniformly + PHI = GRND()*2*PI + SP = cos(PHI) + + ! sample R from cylindrical normal + CALL SAMPLECYLNORMAL(A,B,LORPARAM,R,NTRYR) + + RATIO = EXP(ETA*EB/DEL*R*(SP*SQRT(1-RHO**2)-1)) + + U= GRND() + IF (U.LT.RATIO) EXIT + END DO + + IF (TRY.GE.MAXNTRY) THEN + PRINT*, 'ERROR IN SAMPLERRHOPHI: failed to generate accepted sample' + stop 1 + ENDIF + + NTRIAL = TRY + END SUBROUTINE SAMPLERRHOPHI + + SUBROUTINE SAMPLERELCOORDS(DEL,EB,GAM,EPAR,EPERPH,ETA,NSAMP,COORDS,SHEARABLE) + ! sample relative coordinates Z, R, RHO, PHI for segment junctions + ! generates NSAMP samples and stores them in the NSAMPx4 array COORDS + ! see notes from 4/24/2013 + ! uses rejection sampling for the coupled R,RHO,PHI coordinates + ! EPERPH corresponds to eperp_hat in the notes, but EPERP in the simulation code + ! ETA is -EC/LP in the simulation code and EB=LP + ! see notes from 4/24/2013 + ! if SHEARABLE is set to false do the infinite shear modulus limit + + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EB, GAM,EPAR,EPERPH, ETA + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(4,NSAMP) + LOGICAL, INTENT(IN) :: SHEARABLE + DOUBLE PRECISION :: A,B, C, D, U, LORPARAM(3), UN, R, RHO, PHI, Z + INTEGER :: TRY, NTRYR, SC + DOUBLE PRECISION :: CP, RATIO + + ! maximum rejection trials before giving up + INTEGER, PARAMETER :: MAXNTRY = 100000 + + ! parameters for the cylindrical normal sampling of R + A = EPERPH/2/DEL + B = ETA*EB/EPERPH + ! parameter for the truncated exponential rho sampling + C = EB/DEL + ! parameter for the normal z sampling + D = SQRT(DEL/EPAR) + + ! get enveloping lorentz distribution for R sampling + CALL GETLORENTZENVELOPE(A,B,LORPARAM) + + DO SC = 1,NSAMP + ! sample Z from a normal distribution + UN = RNORM() + Z = UN*D + GAM*DEL + + ! rejection sampling from the coupled r,rho,phi distribution + DO TRY = 1,MAXNTRY + ! sample rho from a truncated exponential + U = GRND() + RHO = 1/C*LOG(EXP(-C)+2*U*SINH(C)) + + ! sample phi uniformly + PHI = GRND()*2*PI + CP = COS(PHI) + + IF (SHEARABLE) THEN + ! sample R from cylindrical normal + CALL SAMPLECYLNORMAL(A,B,LORPARAM,R,NTRYR) + ELSE + R = 0 + ENDIF + + ! decide whether to accept + RATIO = EXP(ETA*EB/DEL*R*(CP*SQRT(1-RHO**2)-1)) + U= GRND() + IF (U.LT.RATIO) EXIT + END DO + + IF (TRY.GE.MAXNTRY) THEN + PRINT*, 'ERROR IN SAMPLERELCOORDS: failed to generate accepted sample' + stop 1 + ENDIF + + COORDS(:,SC) = (/Z,R,RHO,PHI/) + ENDDO + + END SUBROUTINE SAMPLERELCOORDS + + SUBROUTINE SAMPLERELCOORDSNOSHEAR(DEL,EB,GAM,EPAR,NSAMP,COORDS,DOSTRETCH) + ! sample relative coordinates Z, RHO for segment junctions assuming no shear + ! generates NSAMP samples and stores them in the NSAMPx4 array COORDS + ! uses direct normal and exponential sampling + ! PHI is sampled uniformly + + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EB, GAM,EPAR + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(4,NSAMP) + LOGICAL, INTENT(IN) :: DOSTRETCH + DOUBLE PRECISION :: C, D, U, LORPARAM(3), UN, R, RHO, PHI, Z + INTEGER :: SC + DOUBLE PRECISION :: CP, RATIO + ! maximum rejection trials before giving up + INTEGER, PARAMETER :: MAXNTRY = 100000 + + ! parameter for the truncated exponential rho sampling + C = EB/DEL + ! parameter for the normal z sampling + D = SQRT(DEL/EPAR) + + DO SC = 1,NSAMP + IF (DOSTRETCH) THEN + ! sample Z from a normal distribution + UN = RNORM() + Z = UN*D + GAM*DEL + ELSE + Z = GAM*DEL + ENDIF + + ! sample rho from a truncated exponential + U = GRND() + RHO = 1/C*LOG(EXP(-C)+2*U*SINH(C)) + + PHI = 2*PI*GRND() + + COORDS(:,SC) = (/Z,0D0,RHO,PHI/) + ENDDO + + END SUBROUTINE SAMPLERELCOORDSNOSHEAR + + SUBROUTINE SAMPLERELCOORDSGAUSSIAN(DEL,EPAR,EPERP,NSAMP,COORDS) + ! sample relative coordinates segment junctions assuming + ! chain is gaussian + + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EPAR,EPERP + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(4,NSAMP) + DOUBLE PRECISION :: C, D, U, LORPARAM(3), UN, R, RHO, PHI, Z, X1, X2 + INTEGER :: SC + DOUBLE PRECISION :: CP, RATIO + ! maximum rejection trials before giving up + INTEGER, PARAMETER :: MAXNTRY = 100000 + + ! parameter for the truncated exponential rho sampling + C = SQRT(DEL/EPERP) + ! parameter for the normal z sampling + D = SQRT(DEL/EPAR) + + DO SC = 1,NSAMP + UN = RNORM() + Z = UN*D + UN = RNORM() + X1 = UN*C + UN = RNORM() + X2 = UN*C + R = SQRT(X1**2+X2**2) + RHO = 0D0 + PHI = 0D0 + + COORDS(:,SC) = (/Z,R,RHO,PHI/) + ENDDO + + END SUBROUTINE SAMPLERELCOORDSGAUSSIAN + + SUBROUTINE SAMPLERELCOORDSMC(DEL,EB,GAM,EPAR,EPERPH,ETA,NSAMP,SAMPEVERY,& +& INITSAMP,COORDS,FINALRANGES,STARTCOORDS) + ! sample a sequence of relative coordinates using monte carlo sampling + ! for the coupled coordinates r,rho,phi + ! and ordinary gaussian for the stretch coordinate z + ! FINALRANGES is the final step sizes + ! optionally, STARTCOORDS(1:3) gives the starting r,rho,phi coordinates + ! and STARTCOORDS(4:6) gives the starting step ranges for r,rho,phi + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EB, GAM,EPAR,EPERPH, ETA + INTEGER, INTENT(IN) :: NSAMP,SAMPEVERY,INITSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(4,NSAMP), FINALRANGES(3) + DOUBLE PRECISION, INTENT(IN), OPTIONAL :: STARTCOORDS(6) + DOUBLE PRECISION :: D, Z, UN, FACC + INTEGER :: SC + + ! parameter for the normal z sampling + D = SQRT(DEL/EPAR) + + ! sample the independent stretch coordinate + DO SC = 1,NSAMP + ! sample Z from a normal distribution + UN = RNORM() + Z = UN*D + GAM*DEL + COORDS(1,SC) = Z + ENDDO + + ! sample the coupled coordinates + IF (PRESENT(STARTCOORDS)) THEN + CALL MCSAMPLERRHOPHI(DEL,EB,EPERPH,ETA,NSAMP,SAMPEVERY,INITSAMP,COORDS(2:4,:),FACC,FINALRANGES,STARTCOORDS) + ELSE + CALL MCSAMPLERRHOPHI(DEL,EB,EPERPH,ETA,NSAMP,SAMPEVERY,INITSAMP,COORDS(2:4,:),FACC,FINALRANGES) + ENDIF + + END SUBROUTINE SAMPLERELCOORDSMC + + SUBROUTINE MCSAMPLERRHOPHI(DEL,EB,EPERPH,ETA,NSAMP,SAMPEVERY,INITSAMP,COORDS,FACC,FINALRANGES,STARTCOORDS) + ! sample the coupled relative coordinates R, RHO, PHI + ! using metropolis monte carlo + ! should be better than the rejection sampling above for very stiff parameters + ! get a total of NSAMP samples + ! skip the first INITSAMP steps, then sample every SAMPEVERY steps + ! COORDS(:,I) contains values of R,RHO,PHI for the Ith samp + ! FACC gives the overall fraction accepted + ! optionally, STARTCOORDS(1:3) gives the starting r,rho,phi coordinates + ! and STARTCOORDS(4:6) gives the starting step ranges for r,rho,phi + + USE KEYS, ONLY : MCPRINTFREQ,ADJUSTEVERY,FACCTARGET,FACCTOL,ADJUSTSCL + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: DEL,EB,EPERPH,ETA + INTEGER, INTENT(IN) :: NSAMP,SAMPEVERY,INITSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(3,NSAMP), FACC, FINALRANGES(3) + DOUBLE PRECISION, INTENT(IN), OPTIONAL :: STARTCOORDS(6) + DOUBLE PRECISION :: R, RHO, PHI,ENERGY, EPREV, RPREV,RHOPREV,PHIPREV + DOUBLE PRECISION :: DRMIN,DRHOMIN,DRHOMAX,RSTEP,RHOSTEP,PHISTEP + DOUBLE PRECISION :: EPD,EBD,ETAD, DELE, TMP, U, U2, DRHO + INTEGER :: STEP, TOTSTEPS, SAMPCT, TOTACCEPT + LOGICAL :: ACCEPT, ADJUSTED + + TOTACCEPT= 0 + SAMPCT = 0 + + EPD = EPERPH/2/DEL + EBD = EB/DEL + ETAD = ETA*EB/DEL + + ! print*, 'testx1:',EB, ETA, ebd, etad, EPD + + IF (PRESENT(STARTCOORDS)) THEN + R = STARTCOORDS(1); RHO = STARTCOORDS(2); PHI = STARTCOORDS(3); + RSTEP = STARTCOORDS(4); RHOSTEP = STARTCOORDS(5); PHISTEP = STARTCOORDS(6) + ELSE + PHI = 0D0; RHO = 1D0-min(sqrt(1/ebd)*0.1,1d0); R = SQRT(1D0/EPD)*0.1 + ENDIF + !EPREV = EPD*R**2 + EPREV = -LOG(R)+EPD*R**2 - ETAD*R*COS(PHI)*SQRT(1-RHO**2) - EBD*RHO + !print*, 'testx0:', eprev, r,rho,phi + + RSTEP = SQRT(1D0/EPD); + RHOSTEP = MIN(SQRT(1D0/EBD),1D0); + PHISTEP= MIN(SQRT(1D0/ETAD),2*PI); + + TOTSTEPS = INITSAMP+NSAMP*SAMPEVERY + DO STEP = 1,TOTSTEPS + RPREV = R; RHOPREV = RHO; PHIPREV = PHI; + + ! take a step, keeping R, RHO, and PHI within bounds + !DRMIN = MIN(R,RSTEP) + U = GRND() + !R = R + U*(RSTEP+DRMIN)-DRMIN + R = R + U*2*RSTEP - RSTEP + + PHI = PHI + GRND()*2*PHISTEP - PHISTEP + + IF (PHI.GT.2*PI) THEN + PHI = PHI - 2*PI + ELSEIF (PHI.LT.0) THEN + PHI = PHI + 2*PI + ENDIF + + ! DRHO = MIN(MIN(1-RHO,RHO+1),RHOSTEP) + ! U2 = GRND() + ! PRINT*, 'TESTX1:', RHO, DRHO, RHOSTEP, U2*2*DRHO-DRHO + ! RHO = RHO + U2*2*DRHO-DRHO + ! IF (ABS(RHO).GT.1) THEN + ! PRINT*, 'ERROR IN MCRELSAMPLE: BAD RHO', RHO + ! STOP 1 + ! ENDIF + !DRHOMIN = MIN(RHO+1,RHOSTEP) + !DRHOMAX = MIN(1-RHO,RHOSTEP) + U2 = GRND() + !PRINT*, 'TESTX2:', RHO, drhomin,drhomax,U2*(DRHOMIN+DRHOMAX)-DRHOMIN + !RHO = RHO + U2*(DRHOMIN+DRHOMAX)-DRHOMIN + RHO = RHO + U2*2*RHOSTEP - RHOSTEP + !IF (RHO.LT.-1D0) THEN + ! RHO = -1D0+EPSILON(1D0) + !ELSEIF(RHO.GT.1D0) THEN + ! RHO = 1D0+EPSILON(1D0) + !ENDIF + + IF (ABS(RHO).GT.1.OR.R.LT.0) THEN + ACCEPT = .FALSE. + ELSE + ACCEPT = .TRUE. + ENDIF + + IF (ACCEPT) THEN + ! calculate change in energy + !ENERGY = EPD*R**2 + ENERGY = -LOG(R)+EPD*R**2 - ETAD*R*COS(PHI)*SQRT(1-RHO**2) - EBD*RHO + + DELE = ENERGY - EPREV + + ! decide whether to accept + IF (DELE.LT.0) THEN + ACCEPT = .TRUE. + ELSE + TMP = GRND() + ACCEPT = (TMP.LT.EXP(-DELE)) + ENDIF + ENDIF + + IF (ACCEPT) THEN + EPREV = ENERGY + + TOTACCEPT = TOTACCEPT+1 + ELSE + ! restore old coords + R = RPREV; RHO = RHOPREV; PHI = PHIPREV + ENERGY = EPREV + ENDIF + + FACC = TOTACCEPT/DBLE(STEP) + + IF (MOD(STEP,MCPRINTFREQ).EQ.0) THEN + PRINT '(A,I20,7G20.10)', 'MCSTEP:', STEP, ENERGY, FACC, R, RHO, PHI, U, RHOSTEP + ENDIF + + IF (STEP.GT.INITSAMP.AND.MOD(STEP-INITSAMP,SAMPEVERY).EQ.0) THEN + SAMPCT = SAMPCT+1 + COORDS(:,SAMPCT) = (/R,RHO,PHI/) + ENDIF + + IF (ADJUSTEVERY.GT.0.AND.MOD(STEP,ADJUSTEVERY).EQ.0) THEN + ! check whether ranges need adjusting + IF (FACC.LT.FACCTARGET-FACCTOL) THEN + ! PRINT*, 'TESTX1:', RSTEP, RSTEP/ADJUSTSCL + RSTEP = RSTEP/ADJUSTSCL + RHOSTEP = RHOSTEP/ADJUSTSCL + PHISTEP = PHISTEP/ADJUSTSCL + ADJUSTED = .TRUE. + ELSEIF (FACC.GT.FACCTARGET+FACCTOL) THEN + RSTEP = RSTEP*ADJUSTSCL + RHOSTEP = MIN(RHOSTEP*ADJUSTSCL,2D0) + PHISTEP = PHISTEP*ADJUSTSCL + ADJUSTED = .TRUE. + ELSE + ADJUSTED = .FALSE. + ENDIF + + !IF (ADJUSTED) PRINT*, 'ADJUSTED RANGES:', RSTEP, RHOSTEP, PHISTEP + ENDIF + ENDDO + + FINALRANGES = (/RSTEP,RHOSTEP,PHISTEP/) + END SUBROUTINE MCSAMPLERRHOPHI + + SUBROUTINE SAMPLERRHOMVN(DEL,EB,EPERPH,ETA,NSAMP,RVALS,RHOVALS,AVGTRY) + ! rejection sampling of R and RHO coordinates using multivariate normal + ! much more efficient for high values of eta than the old version of SAMPLERRHOMVN + ! see notes from 4/30/2013 + IMPLICIT NONE + DOUBLE PRECISION, INTENT(IN) :: DEL,EB,EPERPH,ETA + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(OUT) :: RVALS(NSAMP),RHOVALS(NSAMP), AVGTRY + INTEGER, PARAMETER :: MAXNTRY = 1000 + DOUBLE PRECISION :: A,B,C,D, C2, E + DOUBLE PRECISION :: R,V,U, COV(2,2),MU(2), DISC, PAIR(2), RATIO, I0VAL + INTEGER :: TRY, SC, INFO, TOTTRY + + + ! Set up the multivariate normal envelope distribution for sampling R and V + ! V = sqrt(1-rho) + + A = EPERPH/2/DEL + B = EB/DEL + C = ETA*EB/DEL + C2 = SQRT(2D0)*C + D = SQRT(2*A) + E = SQRT(2*B) + + !PRINT*, 'TESTX0:', A,B,C,D + + ! get mean vector + DISC = 4*A*B-C2*C2 + IF (DISC.LE.0) THEN + PRINT*, 'ERROR IN SAMPLERELCOORDSMVN: negative discriminant. Not a well defined distribution.', A, B, C, DISC + STOP 1 + END IF + MU = (/2*B*D+C2*E,C2*D+2*A*E/)/DISC + ! get covariance matrix (only lower triangular half is nonzero) + COV(1,:) = (/2*B,0D0/) + COV(2,:) = (/C2,2*A/) + COV = COV/DISC + + ! get cholesky decomposition of covariance matrix + CALL DPOTRF('L',2,COV,2,INFO) + IF (INFO.NE.0) THEN + PRINT*, 'ERROR IN SAMPLERELCOORDSMVN: Cholesky decomposition of covariance matrix failed:', INFO + STOP 1 + ENDIF + + TOTTRY = 0 + DO SC = 1,NSAMP + DO TRY = 1,MAXNTRY + ! sample a multivariate normal pair + PAIR = MVNORM(2,MU,COV) + R=PAIR(1); V = PAIR(2) + + !print*, 'testx2:', sc, try, r, v + IF (V.LE.0.OR.V.GE.2.OR.R.LE.0) THEN + ! reject if R or V are out of bounds + CYCLE + ENDIF + + ! uniform deviate + U = GRND() + ! accept if below ratio + CALL BESSF_I0(C*R*V*SQRT(2-V*V),I0VAL) + RATIO = R*V*I0VAL*D*E*EXP(-C2*R*V - D*R - E*V + 2) + !print*, 'TESTX1:', sc, TRY, RATIO, u + IF (U.LT.RATIO) THEN + EXIT + ENDIF + END DO + TOTTRY = TOTTRY + TRY + IF (TRY.GE.MAXNTRY) THEN + PRINT*, 'ERROR IN SAMPLERRHOMVN: failed to generate acceptable sample' + STOP 1 + ENDIF + + RVALS(SC) = R + RHOVALS(SC) = 1 - V*V + ENDDO + + AVGTRY = TOTTRY/NSAMP + END SUBROUTINE SAMPLERRHOMVN + + SUBROUTINE SAMPLEPHICOND(NSAMP,COEFF,RVALS,RHOVALS,PHIVALS,AVGTRY) + ! sample PHI from a conditional distribution with given R and RHO values + ! use rejection sampling with normal distrib envelope + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(IN) :: RVALS(NSAMP), RHOVALS(NSAMP), COEFF + DOUBLE PRECISION, INTENT(OUT) :: PHIVALS(NSAMP), AVGTRY + INTEGER, PARAMETER :: MAXNTRY = 1000 + INTEGER :: SC, TRY, tottry + DOUBLE PRECISION :: D, PHI, U, RATIO + + TOTTRY = 0 + DO SC = 1,NSAMP + D = COEFF*RVALS(SC)*SQRT(1 - RHOVALS(SC)**2) + + DO TRY = 1,MAXNTRY + ! sample from normal distrib + PHI = RNORM()/SQRT(0.4*D) + + IF (ABS(PHI).GT.PI) CYCLE + + ! sample from uniform + U = GRND() + ! decide whether to reject + RATIO = EXP(D*(COS(PHI)-1+0.2*PHI*PHI)) + +! print*, 'testx1:', phi, u, ratio, try + IF (U.LT.RATIO) THEN + EXIT + ENDIF + ENDDO + IF (TRY.GE.MAXNTRY) THEN + PRINT*, 'ERROR IN SAMPLEPHICOND: failed to generate acceptable sample.' + STOP 1 + ENDIF + PHIVALS(SC) = PHI + TOTTRY = TOTTRY + TRY + ENDDO + + AVGTRY = dble(TOTTRY)/NSAMP + END SUBROUTINE SAMPLEPHICOND + + SUBROUTINE SAMPLERELCOORDSMVN(DEL,EB,GAM,EPAR,EPERPH,ETA,NSAMP,COORDS) + ! sample relative coordinates Z, R, RHO, PHI for segment junctions + ! generates NSAMP samples and stores them in the NSAMPx4 array COORDS + ! uses rejection sampling with multivariate normal (see notes from 4/30/2013) + ! Should be significantly more efficient for high eta values + ! EPERPH corresponds to eperp_hat in the notes, but EPERP in the simulation code + ! ETA is -EC/LP in the simulation code and EB=LP + + + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: DEL, EB, GAM,EPAR,EPERPH, ETA + INTEGER, INTENT(IN) :: NSAMP + DOUBLE PRECISION, INTENT(OUT) :: COORDS(4,NSAMP) + DOUBLE PRECISION :: ZSIG, U, AVGTRY + INTEGER :: SC + + ! sample the Z values from a normal distribution + ZSIG = SQRT(DEL/EPAR) + DO SC = 1,NSAMP + U = RNORM() + COORDS(1,SC) = U*ZSIG + GAM*DEL + ENDDO + + ! sample the R and RHO values using rejection sampling with multivariate normal + CALL SAMPLERRHOMVN(DEL,EB,EPERPH,ETA,NSAMP,COORDS(2,:),COORDS(3,:),AVGTRY) + + ! sample the PHI values conditional on the r, rho + ! using rejection sample with normal envelope + CALL SAMPLEPHICOND(NSAMP,ETA*EB/DEL,COORDS(2,:),COORDS(3,:),COORDS(4,:),AVGTRY) + END SUBROUTINE SAMPLERELCOORDSMVN +END MODULE SAMPLEUTIL diff --git a/BasicWLC/dssWLC/source/test.f90 b/BasicWLC/dssWLC/source/test.f90 new file mode 100644 index 00000000..9617ad98 --- /dev/null +++ b/BasicWLC/dssWLC/source/test.f90 @@ -0,0 +1,102 @@ +PROGRAM MAIN + + call testbessel + !CALL TESTMULTINORM + !CALL TESTCHOLESKY + !CALL TESTMULTINORM +CONTAINS + + SUBROUTINE TESTBESSEL + ! test bessel function + implicit none + DOUBLE PRECISION :: X, ANS + + X = 5D0 + CALL BESSF_I0(X,ANS) + PRINT*, ANS + END SUBROUTINE TESTBESSEL + +SUBROUTINE TESTMULTINORM + ! test multivariate normal random number generator + USE MT19937, ONLY : RNORM, MVNORM + IMPLICIT NONE + INTEGER, PARAMETER :: N = 2, NDEV = 10000 + DOUBLE PRECISION :: COV(N,N), CHOLCOV(N,N) + DOUBLE PRECISION :: Y(N), XDEV(NDEV,N), MU(N) + INTEGER :: INFO, I, J + + MU = (/1D0,-2D0/) + + ! covariance matrix + COV(1,:) = (/4D0,0D0/) + COV(2,:) = (/2D0,3D0/) + + CHOLCOV = COV + CALL DPOTRF('L',N,CHOLCOV,N,INFO) + + ! PRINT*, 'INFO:', INFO + + DO I = 1,NDEV + XDEV(I,:) = MVNORM(N,MU,CHOLCOV) + PRINT*, XDEV(I,:) + END DO + + ! ! Get standard normal random deviates + ! DO I = 1,NDEV + ! DO J = 1,N + ! Y(J) = RNORM() + ! ENDDO + + ! ! convert to multivariate normal deviates + CALL DTRMV('L','N','N',N,CHOLCOV,N,Y,1) + ! XDEV(I,:) = Y + MU + ! PRINT*, XDEV(I,:) + ! END DO + + + + END SUBROUTINE TESTMULTINORM + +SUBROUTINE TESTCHOLESKY + ! test cholesky decomposition with lapack + IMPLICIT NONE + INTEGER, PARAMETER :: N = 3, LDA = N + DOUBLE PRECISION :: A(N,N), XVEC(N) + INTEGER :: INFO, I + + A(1,:) = (/6D0,0D0,0D0/) + A(2,:) = (/2D0,4D0,0D0/) + A(3,:) = (/3D0, 0D0, 5D0/) + + CALL DPOTRF('L',N,A,LDA,INFO) + + PRINT*, 'INFO:', INFO + + DO I = 1,N + PRINT*, A(I,:) + END DO + + ! test matrix-vector multiple + XVEC = (/1D0,2D0,-3D0/) + CALL DTRMV('L','N','N',N,A,N,XVEC,1) + + PRINT*, 'XVEC:', XVEC +END SUBROUTINE TESTCHOLESKY + +! SUBROUTINE TESTQUARTIC +! ! test the quartic equation solver + +! IMPLICIT NONE +! DOUBLE PRECISION :: COEFF(5), SOL(4),SOLI(4) +! INTEGER :: NSOL + +! !COEFF = (/2.,5.1,-1.,0.,-1./) +! COEFF = (/-1d0,0d0,-1d0,5.1d0,2d0/) + +! CALL QUARTIC(COEFF,SOL,SOLI,NSOL) + +! PRINT*, NSOL +! PRINT*, 'SOL', SOL +! PRINT*, 'SOLI', SOLI +! END SUBROUTINE TESTQUARTIC +END PROGRAM MAIN diff --git a/BasicWLC/dssWLC/source/testmain.f90 b/BasicWLC/dssWLC/source/testmain.f90 new file mode 100644 index 00000000..c999c98c --- /dev/null +++ b/BasicWLC/dssWLC/source/testmain.f90 @@ -0,0 +1,946 @@ +PROGRAM MAIN + IMPLICIT NONE + +! CALL TESTBEADQINT +! CALL TESTBEADROD +! CALL TESTMCSAMPLEREL +! CALL TESTCHAINEQUIL +! CALL TESTSAMPLEUTILS +! CALL TESTANALYTIC +! CALL TESTREADSNAP +! CALL TESTBROWNDYN +! CALL TESTCHAINGROUP + CALL TESTCHAINFORCE + ! CALL CHECKMINIMONTECARLO + ! CALL CHECKREMOVEADDBEAD +! CALL CHECKREDISC +! CALL CHECKSPHEREINTERSECT +! CALL CHECKCUBICROOT +! CALL TESTCRANK + +CONTAINS + SUBROUTINE TESTBEADQINT + ! test calculation of bead partition function integrated over R or U + USE CHAINUTIL + USE KEYS + USE SAMPLEUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLCLIST(1) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: SC, B, NRHO, NPHI + DOUBLE PRECISION :: DR(3), LASTCOORDS(6), ENERGY1, ENERGY2, QINT + + CHAINP=>WLCLIST(1); + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + + print*, 'chain info:', chainp%npt + + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,LASTCOORDS) + B=2 + CALL GETBEADENERGY(CHAINP,B,ENERGY1) + CALL GETBEADENERGY(CHAINP,B+1,ENERGY2) + print*, 'current energy:', energy1+energy2 + + !CALL GETBEADQUINT(CHAINP,B,NRHO,NPHI,QINT) + print*, 'testx1:', intrweightnpt + CALL GETBEADQRINT(CHAINP,B,INTRWEIGHTNPT,QINT) + PRINT*, 'QINT, free energy:', QINT, -LOG(QINT) + + CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,1,.FALSE.) + + CALL CLEANUPCHAIN(CHAINP) + END SUBROUTINE TESTBEADQINT + + SUBROUTINE TESTBEADROD + ! test bead-rod forces by comparing to andy's code + USE MT19937 + USE CHAINUTIL + USE KEYS + USE SAMPLEUTIL + USE BROWNDYN + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLCLIST(1) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: b + DOUBLE PRECISION :: DR(3), LASTCOORDS(6), ENERGY + DOUBLE PRECISION, ALLOCATABLE :: BROWNFORCE(:,:),RFORCE(:,:) + DOUBLE PRECISION :: DELT, S2DTR + + CHAINP=>WLCLIST(1); + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + + CALL GETEQUILCHAIN(CHAINP,2,LASTCOORDS) + + ! CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,1,.FALSE.) + ! OPEN(UNIT=55,FILE='initsnap',status='unknown') + ! DO B= 1,CHAINP%NPT + ! print*, b, chainp%pos(:,b) + ! WRITE(55,*) CHAINP%POS(:,B) + ! ENDDO + ! CLOSE(55) + + ALLOCATE(BROWNFORCE(3,CHAINP%NPT),RFORCE(3,CHAINP%NPT)) + DELT = DELTSCL*CHAINP%FRICTR + !CALL GETBEADRODFORCE(CHAINP,BROWNFORCE,BRCRELAX,RFORCE,ENERGY) + !DO B= 1,CHAINP%NPT + ! print*, b, RFORCE(:,b) + !ENDDO + + ! ------ test forces--------- + ! S2DTR = SQRT(2*CHAINP%FRICTR/DELT) + ! OPEN(UNIT=55,FILE='brownpos.out') + ! DO B = 1,CHAINP%NPT + ! ! translational brownian force + + ! BROWNFORCE(1,B) = RNORM()*S2DTR + ! BROWNFORCE(2,B) = RNORM()*S2DTR + ! BROWNFORCE(3,B) = RNORM()*S2DTR + ! WRITE(55,*) BROWNFORCE(:,B) + ! ENDDO + ! CLOSE(55) + + ! CALL GETBEADRODFORCE(CHAINP,BROWNFORCE,BRCRELAX,RFORCE,ENERGY) + ! DO B= 1,CHAINP%NPT + ! print*, b, RFORCE(:,b)+brownforce(:,b) + ! ENDDO + ! --------------------------- + + ! --------test BD steps ------------ + CALL LANGEVINSTEPRK4(CHAINP,DELT,ENERGY,.TRUE.) + print*, 'testx6:' + do b = 1,chainp%npt + print*, chainp%pos(:,b) + enddo + stop 1 + + DEALLOCATE(BROWNFORCE,RFORCE) + CALL CLEANUPCHAIN(CHAINP) + END SUBROUTINE TESTBEADROD + + SUBROUTINE TESTCHAINEQUIL + ! test equilibrium sampling of chain config + USE CHAINUTIL + USE KEYS + USE SAMPLEUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLCLIST(1) + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: SC + DOUBLE PRECISION :: DR(3), LASTCOORDS(6) + + CHAINP=>WLCLIST(1); + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + + print*, 'chain info:', chainp%npt + + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + DO SC = 1,MCTOTSTEPS + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,LASTCOORDS) + DR = CHAINP%POS(:,CHAINP%NPT)-CHAINP%POS(:,1) + IF (MOD(SC,MCPRINTFREQ).EQ.0) THEN + PRINT*, SC, DR + ENDIF + WRITE(55,*) DR + ENDDO + CLOSE(55) + !CALL OUTPUTSNAPSHOT(CHAINP,SNAPSHOTFILE,1,.FALSE.) + + CALL CLEANUPCHAIN(CHAINP) + END SUBROUTINE TESTCHAINEQUIL + + SUBROUTINE TESTMCSAMPLEREL + ! test monte carlo sampling of coupled relative coordinates + USE KEYS + USE SAMPLEUTIL + IMPLICIT NONE + DOUBLE PRECISION, ALLOCATABLE :: COORDS(:,:) + DOUBLE PRECISION :: FACC, FINALRANGES(3) + INTEGER :: C + + CALL READKEY + + ALLOCATE(COORDS(4,MAXNPT)) + + IF (EQUILSAMPLETYPE.EQ.3) THEN + !CALL MCSAMPLERRHOPHI(LS,LP,EPERP,-EC/LP,MAXNPT,MCSTATSTEPS,MCINITSTEPS,COORDS,FACC) + CALL SAMPLERELCOORDSMC(LS,LP,GAM,EPAR,EPERP,-EC/LP,MAXNPT,MCSTATSTEPS,& +& MCINITSTEPS,COORDS,FINALRANGES) + ELSEIF (EQUILSAMPLETYPE.EQ.2) THEN + print*, 'not set up yet' + ELSEIF (EQUILSAMPLETYPE.EQ.1) THEN + CALL SAMPLERELCOORDS(LS,LP,GAM,EPAR,EPERP,-EC/LP,MAXNPT,COORDS) + ENDIF + + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + DO C = 1,MAXNPT + WRITE(55,*) COORDS(:,C) + ENDDO + CLOSE(55) + + !PRINT*, 'FINAL FACC:', FACC + DEALLOCATE(COORDS) + END SUBROUTINE TESTMCSAMPLEREL + + SUBROUTINE TESTSAMPLEUTILS + ! test some sampling subroutines + USE KEYS + USE SAMPLEUTIL + IMPLICIT NONE + DOUBLE PRECISION :: RVAL, RHOVAL,PHIVAL,LORPARAM(3), A, B + INTEGER :: C, ntry + DOUBLE PRECISION, ALLOCATABLE :: COORDS(:,:) + DOUBLE PRECISION :: AVGTRY + + CALL READKEY + + ! test sampling from cylindrical normal + ! A = 0.1D0; B = 2D0 + ! CALL GETLORENTZENVELOPE(A,B,LORPARAM) + ! PRINT*, 'PARAMETERS:', LORPARAM + + ! OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + ! DO C = 1,NCHAIN + ! IF (MOD(C,1000).EQ.0) PRINT*, C + ! CALL SAMPLECYLNORMAL(A,B,LORPARAM,RVAL,NTRY) + ! WRITE(55,*) RVAL, NTRY + ! ENDDO + ! CLOSE(55) + + ! test rho sampling + ! OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + ! DO C = 1,NCHAIN + ! IF (MOD(C,1000).EQ.0) PRINT*, C + ! CALL SAMPLERRHO(LS,LP,EPERP,-EC/LP,RVAL,RHOVAL) + ! WRITE(55,*) RHOVAL + ! ENDDO + ! CLOSE(55) + + ! test full rejection sampling of r, rho, and phi + ! OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + ! DO C = 1,NCHAIN + ! IF (MOD(C,1000).EQ.0) PRINT*, C + ! CALL SAMPLERRHOPHI(LS,LP,EPERP,-EC/LP,RVAL,RHOVAL,PHIVAL,NTRY) + ! WRITE(55,*) RVAL,RHOVAL,PHIVAL,NTRY + ! ENDDO + ! CLOSE(55) + !PRINT*, RVAL, RHOVAL, PHIVAL, NTRY + + ! Test overall sampling of all relative coordinates + ALLOCATE(COORDS(4,NCHAIN)) + CALL SAMPLERELCOORDS(LS,LP,GAM,EPAR,EPERP,-EC/LP,NCHAIN,COORDS) + !COORDS(1:2,:) = COORDS(2:3,:) + CALL SAMPLERRHOMVN(LS,LP,EPERP,-EC/LP,NCHAIN,COORDS(2,:),COORDS(3,:),AVGTRY) + CALL SAMPLEPHICOND(NCHAIN,-EC/LS,COORDS(2,:),COORDS(3,:),COORDS(1,:),AVGTRY) + PRINT*, 'avg try:', AVGTRY + OPEN(UNIT=55,FILE=OUTFILE,STATUS='UNKNOWN') + DO C = 1,NCHAIN + WRITE(55,*) COORDS(:,C) + ENDDO + CLOSE(55) + DEALLOCATE(COORDS) + + END SUBROUTINE TESTSAMPLEUTILS + + SUBROUTINE TESTANALYTIC + ! test analytic calculations for chain dynamics + ! starting with testing the force calculations for finely discretized chain + USE CHAINUTIL + USE KEYS + USE BROWNDYN + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLCLIST(1) + TYPE(OBSTACLE), TARGET :: OB + TYPE(CHAIN), POINTER :: CHAINP + TYPE(OBSTACLE), POINTER :: OBP + DOUBLE PRECISION :: ENERGY, ENERGY0 + DOUBLE PRECISION, ALLOCATABLE :: RFORCE(:,:),RFORCETMP(:,:),UFORCE(:,:),UFORCETMP(:,:),BROWNPOS(:,:) + DOUBLE PRECISION, PARAMETER :: TINY = 1D-7 + ! DOUBLE PRECISION :: OBSTPOS(3), OBSTRAD, OBSTMOD + ! DOUBLE PRECISION :: OBFORCE(3),OBFORCETMP(3) + INTEGER :: C, b, nread + DOUBLE PRECISION :: DEL, TMPVEC(3) + + CHAINP=>WLCLIST(1); !OBP=>OB + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + + PRINT*, 'CHAIN INFO:', CHAINP%NPT, CHAINP%LS(1) + + CALL INPUTSNAPSHOT(WLCLIST,1,RESTARTFILE,0,NREAD) + + PRINT*, 'NREAD:', NREAD + + CALL OUTPUTSNAPSHOT(CHAINP,OUTFILE,1,.FALSE.) + + ALLOCATE(RFORCE(3,CHAINP%NPT),RFORCETMP(3,CHAINP%NPT),BROWNPOS(3,CHAINP%NPT)) + ALLOCATE(UFORCE(3,CHAINP%NPT),UFORCETMP(3,CHAINP%NPT)) + + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY0,.TRUE.) + ELSE + print*, 'NOT SET UP FOR BEADRODFORCE YET' + STOP 1 + !CALL GETBEADRODFORCE(CHAINP,BROWNPOS,RFORCE,ENERGY0) + ENDIF + + B = 30; DEL = CHAINP%LS(1); + print*, 'RFORCE:', RFORCE(:,B) + print*, 'UFORCE:', UFORCE(:,B) + PRINT*, 'UFORCE, U ANGLE:', DOT_PRODUCT(UFORCE(:,B),CHAINP%UVEC(:,B))/NORM(UFORCE(:,B)) + TMPVEC = UFORCE(:,B)-DOT_PRODUCT(UFORCE(:,B),CHAINP%UVEC(:,B))*CHAINP%UVEC(:,B) + print*, 'projected uforce:', TMPVEC + call CROSS_PRODUCT(UFORCE(:,B)/NORM(UFORCE(:,B)),CHAINP%UVEC(:,B),TMPVEC) + PRINT*, 'CROSSPROD:', TMPVEC + print*, 'testx1:' + print*, chainp%uvec(:,b-1) + print*, chainp%uvec(:,b) + print*, chainp%uvec(:,b+1) + print*, 'DU:', (CHAINP%UVEC(:,B+1)-CHAINP%UVEC(:,B-1))/(2*DEL), del, CHAINP%UVEC(:,B+1)-CHAINP%UVEC(:,B-1) + print*, 'DR:', (CHAINP%POS(:,B+1)-CHAINP%POS(:,B-1))/(2*DEL) + + DEALLOCATE(RFORCE,RFORCETMP,UFORCE,UFORCETMP,BROWNPOS) + END SUBROUTINE TESTANALYTIC + + SUBROUTINE TESTREADSNAP + ! test reading in of snapshots + USE CHAINUTIL + USE KEYS + USE BROWNDYN + IMPLICIT NONE + TYPE(CHAIN), ALLOCATABLE,TARGET :: WLCLIST(:) + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: ENERGY, ENERGY0, KT, DELT + DOUBLE PRECISION, PARAMETER :: TINY = 1D-6 + INTEGER :: C, b, STEP,NREAD + + ! CHAINP=>WLC; !OBP=>OB + CALL READKEY + NCHAIN = 5 + + ALLOCATE(WLCLIST(NCHAIN)) + DO C = 1,NCHAIN + CHAINP=>WLCLIST(C) + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + ENDDO + + CALL INPUTSNAPSHOT(WLCLIST,NCHAIN,SNAPSHOTFILE,1,NREAD) + PRINT*, 'NREAD:', NREAD + PRINT*, WLCLIST(1)%POS(:,1) + PRINT*, WLCLIST(2)%UVEC(:,2) + + DO C = 1,NCHAIN + CHAINP=>WLCLIST(C) + CALL CLEANUPCHAIN(CHAINP) + ENDDO + DEALLOCATE(WLCLIST) + END SUBROUTINE TESTREADSNAP + + SUBROUTINE TESTBROWNDYN + ! test brownian dynamics step subroutine + USE CHAINUTIL + USE KEYS + USE BROWNDYN + IMPLICIT NONE + TYPE(CHAIN), ALLOCATABLE,TARGET :: WLCLIST(:) + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: ENERGY, ENERGY0, KT, DELT + DOUBLE PRECISION, ALLOCATABLE :: RFORCE(:,:),UFORCE(:,:) + DOUBLE PRECISION, PARAMETER :: TINY = 1D-6 + + INTEGER :: C, b, STEP + + ! CHAINP=>WLC; !OBP=>OB + CALL READKEY + ALLOCATE(WLCLIST(NCHAIN)) + DO C = 1,NCHAIN + CHAINP=>WLCLIST(C) + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + ENDDO + + CHAINP=>WLCLIST(1) + ALLOCATE(RFORCE(3,CHAINP%NPT),UFORCE(3,CHAINP%NPT)) + + CALL OUTPUTSNAPSHOT(CHAINP,'start.out',1,.FALSE.) + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY0,.TRUE.) + print*, 'start energy:', ENERGY0 + + KT = 1D0 + DELT = DELTSCL*KT/MAX(CHAINP%FRICTR,CHAINP%FRICTU)/(CHAINP%DELS(1))**2 + PRINT*, 'DELT:', DELT, outfile + OPEN(99,FILE=OUTFILE,STATUS='UNKNOWN') + write(99,*) NCHAIN + DO STEP=1,10000 + DO C = 1,NCHAIN + CHAINP=>WLCLIST(C) + CALL LANGEVINSTEP(CHAINP,DELT,KT,ENERGY) + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY,.TRUE.) + IF (MOD(STEP,100).EQ.0.AND.C.EQ.1) PRINT*, 'STEP, ENERGY:', STEP, ENERGY + if (MOD(STEP,1).EQ.0) WRITE(99,*) STEP, C, ENERGY + ENDDO + ENDDO + CLOSE(99) + + CHAINP=>WLCLIST(1) + CALL OUTPUTSNAPSHOT(CHAINP,'finish.out',1,.FALSE.) + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY,.TRUE.) + + PRINT*, 'end energy:', ENERGY + + DEALLOCATE(RFORCE,UFORCE) + DO C = 1,NCHAIN + CHAINP=>WLCLIST(C) + CALL CLEANUPCHAIN(CHAINP) + ENDDO + DEALLOCATE(WLCLIST) + END SUBROUTINE TESTBROWNDYN + + SUBROUTINE TESTCHAINGROUP + ! test setup for group of chains + USE MANYCHAINS + USE KEYS + USE INPUTUTIL + IMPLICIT NONE + + TYPE(CHAINGROUP),TARGET :: GROUP + TYPE(CHAINGROUP), POINTER :: CGRP + INTEGER :: NCON,NPT,NC,C, I,B, STARTSTEP + DOUBLE PRECISION :: DIST, energy, SHEARMAT(3,3),DIFF(3) + TYPE(CHAIN), POINTER :: CHAINP + LOGICAL :: FILEEXISTS, SUCCESS + + CGRP=>GROUP + + CALL READKEY + + NCON = NCONNECT + IF (SQUARELATTICE) THEN + NCON = NCON + (NCHAIN/2)**2 + ELSEIF (DIAMONDLATTICE) THEN + NCON = NCON + NDIAMOND(1)*NDIAMOND(2) + (NDIAMOND(1)+1)*(NDIAMOND(2)+1) - 4 + ENDIF + + CALL SETUPCHAINGROUP(CGRP,NCHAIN,NCON,NFORCE,MAXNPT) + CALL SETCHAINGROUPPARAMS(CGRP) + + NPT = CGRP%CHAINS(1)%NPT + NC = NCHAIN/2 + + IF (SQUARELATTICE) THEN + DIST = (NPT-1)/(NC-1)*LS*gam + CALL INITIALIZESQUARELATTICE(CGRP,DIST) + ELSEIF (DIAMONDLATTICE) THEN + CALL INITIALIZEDIAMONDLATTICE(CGRP,LS*GAM,NDIAMOND,LENDIAMOND,WIDTHDIAMOND) + ELSE + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + CALL INITIALIZECHAIN(CHAINP,.FALSE.) + ENDDO + ENDIF + + ! apply shear deformation + SHEARMAT = 0D0 + DO I = 1,3 + SHEARMAT(I,I) = 1D0 + ENDDO + IF (SETSHEAR) THEN + SHEARMAT(2,3)= SHEARGAMMA + ENDIF + CALL APPLYDEFORM(CGRP,SHEARMAT) + + STARTSTEP = 0 + IF (RESTART) THEN + INQUIRE(FILE=RESTARTFILE,EXIST=FILEEXISTS) + IF (FILEEXISTS) THEN + print*, 'Reading structure from file:', TRIM(ADJUSTL(RESTARTFILE)) + CALL READSNAPSHOTS(CGRP,RESTARTFILE,.FALSE.,STARTSTEP,SUCCESS) + print*, 'Successfully read?:', SUCCESS, STARTSTEP + ELSE + PRINT*, 'WARNING: no restart file found!' + ENDIF + ENDIF + + + + PRINT*, 'CHAIN LENGTHS:' + DO C = 1,CGRP%NCHAIN + PRINT*, C, CGRP%CHAINS(C)%NPT + ENDDO + + ! list all connections + PRINT*, 'CONNECTIONS:' + DO C = 1,CGRP%NCONNECT + PRINT*, C, CGRP%CONNECT(C,:) + ENDDO + + PRINT*, 'FIXED BEADS:' + DO C = 1,CGRP%NCHAIN + DO B = 1,CGRP%CHAINS(C)%NPT + IF (ANY(CGRP%FIXBEAD(B,C,:))) THEN + PRINT*, B,C, CGRP%FIXBEAD(B,C,:) + ENDIF + ENDDO + ENDDO + + PRINT*, 'SEGMENT LENGTHS:' + DO C = 1,CGRP%NCHAIN + CHAINP=>CGRP%CHAINS(C) + DO B = 2,CHAINP%NPT + DIFF = CHAINP%POS(:,B)-CHAINP%POS(:,B-1) + DIST = SQRT(DOT_PRODUCT(DIFF,DIFF)) + PRINT*, B,C,DIST + ENDDO + ENDDO + + ! output snapshot + CALL GROUPSNAPSHOT(CGRP,SNAPSHOTFILE,0,.FALSE.) + + CALL GROUPENERGY(CGRP,ENERGY) + PRINT*, 'ENERGY:', ENERGY + + CALL CLEANUPCHAINGROUP(CGRP) + + END SUBROUTINE TESTCHAINGROUP + + SUBROUTINE CHECKREDISC + ! test rediscretization of chain + + USE CHAINUTIL + USE KEYS + USE REDISC + USE GENUTIL + USE INPUTUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, IND + DOUBLE PRECISION :: ENERGY, DELE, NEWENERGY + LOGICAL :: SUCCESS, FILEEXISTS + INTEGER :: STARTSTEP + DOUBLE PRECISION :: STARTENERGY, ENDENERGY + DOUBLE PRECISION :: DIFF(3) + INTEGER :: B + + CHAINP=>WLC + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + + IF (RESTART) THEN + INQUIRE(FILE=RESTARTFILE,EXIST=FILEEXISTS) + IF (FILEEXISTS) THEN + print*, 'Reading structure from file:', TRIM(ADJUSTL(RESTARTFILE)) +! CALL READSNAPSHOTS(CHAINP,RESTARTFILE,STARTSTEP,SUCCESS) + print*, 'Successfully read?:', SUCCESS, CHAINP%NPT + ELSE + PRINT*, 'WARNING: restart file not found' + ENDIF + ENDIF + + CALL OUTPUTSNAPSHOT(CHAINP,'start.out',0,.FALSE.) + + CALL READPARAMDATA('shearWLCparams.data') + + CALL GETENERGY(CHAINP,STARTENERGY) + PRINT*, 'STARTING ENERGY:', STARTENERGY + + DO B = 1,CHAINP%NPT-1 + DIFF = CHAINP%POS(:,B+1)-CHAINP%POS(:,B) + PRINT*, B, SQRT(DOT_PRODUCT(DIFF,DIFF)), CHAINP%LS(B), chainp%gam(b), chainp%beadenergy(b) + ENDDO + + CALL REDISCADD(CHAINP,DELE) + ! CALL REDISCREMOVe(CHAINP,DELE) + print*, 'Number of beads:', CHAINP%NPT + PRINT*, 'DELE:', DELE + + CALL GETENERGY(CHAINP,ENDENERGY) + PRINT*, 'END ENERGY:', ENDENERGY, STARTENERGY+DELE + + + CALL OUTPUTSNAPSHOT(CHAINP,'finish.out',0,.FALSE.) + + CALL CLEANUPCHAIN(CHAINP) + CALL CLEANUPDATA + END SUBROUTINE CHECKREDISC + + SUBROUTINE CHECKREMOVEADDBEAD + ! test removing and adding of a bead + USE CHAINUTIL + USE KEYS + USE REDISC + USE GENUTIL + USE INPUTUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, IND + DOUBLE PRECISION :: ENERGY, DELE, NEWENERGY + LOGICAL :: SUCCESS, FILEEXISTS + INTEGER :: STARTSTEP + DOUBLE PRECISION :: STARTENERGY, ENDENERGY, DIFF(3), ND + + CHAINP=>WLC + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.false.,INITRANGE) + + CALL READPARAMDATA('shearWLCparams.data') + + IF (RESTART) THEN + INQUIRE(FILE=RESTARTFILE,EXIST=FILEEXISTS) + IF (FILEEXISTS) THEN + print*, 'Reading structure from file:', TRIM(ADJUSTL(RESTARTFILE)) +! CALL READSNAPSHOTS(CHAINP,RESTARTFILE,STARTSTEP,SUCCESS) + print*, 'Successfully read?:', SUCCESS + ELSE + PRINT*, 'WARNING: restart file not found' + ENDIF + ENDIF + print*, 'npt:', chainp%npt + CALL OUTPUTSNAPSHOT(CHAINP,'start.out',0,.FALSE.) + CALL GETENERGY(CHAINP,ENERGY) + print*, 'initial energy:', ENERGY + DO C = 1,CHAINP%NPT-1 + DIFF = CHAINP%POS(:,C+1)-CHAINP%POS(:,C) + ND = SQRT(DOT_PRODUCT(DIFF,DIFF)) + PRINT*, C, chainp%beadenergy(c), chainp%lp(c) + ENDDO + + CALL ADDBEAD(CHAINP,3,DELE) + + + !CALL REMOVEBEAD(CHAINP,9,DELE) + + CALL GETENERGY(CHAINP,NEWENERGY) + ! DO C = 1,CHAINP%NPT-1 + ! PRINT*, CHAINP%LS(C), CHAINP%LP(C), CHAINP%BEADENERGY(C+1) + ! ENDDO + + PRINT*, 'DELE:', DELE + PRINT*, ENERGY+DELE + PRINT*, NEWENERGY, SUM(CHAINP%BEADENERGY(1:CHAINP%NPT)) + print*, 'npt:', chainp%npt + CALL OUTPUTSNAPSHOT(CHAINP,'finish.out',0,.FALSE.) + END SUBROUTINE CHECKREMOVEADDBEAD + + SUBROUTINE CHECKMINIMONTECARLO + ! test single bead montecarlo + USE CHAINUTIL + USE KEYS + USE REDISC + USE GENUTIL + USE INPUTUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, IND + DOUBLE PRECISION :: ENERGY, DELE, NEWENERGY + LOGICAL :: SUCCESS, FILEEXISTS + INTEGER :: STARTSTEP + DOUBLE PRECISION :: STARTENERGY, ENDENERGY, DIFF(3), ND + + CHAINP=>WLC + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.false.,INITRANGE) + + CALL READPARAMDATA('shearWLCparams.data') + + IF (RESTART) THEN + INQUIRE(FILE=RESTARTFILE,EXIST=FILEEXISTS) + IF (FILEEXISTS) THEN + print*, 'Reading structure from file:', TRIM(ADJUSTL(RESTARTFILE)) +! CALL READSNAPSHOTS(CHAINP,RESTARTFILE,STARTSTEP,SUCCESS) + print*, 'Successfully read?:', SUCCESS + ELSE + PRINT*, 'WARNING: restart file not found' + ENDIF + ENDIF + print*, 'npt:', chainp%npt + CALL OUTPUTSNAPSHOT(CHAINP,'start.out',0,.FALSE.) + CALL GETENERGY(CHAINP,ENERGY) + print*, 'initial energy:', ENERGY + ! DO C = 1,CHAINP%NPT-1 + ! DIFF = CHAINP%POS(:,C+1)-CHAINP%POS(:,C) + ! ND = SQRT(DOT_PRODUCT(DIFF,DIFF)) + ! PRINT*, C, CHAINP%ls(c), ND, CHAINP%POS(:,C) + ! ENDDO + + CALL MINIMONTECARLO(CHAINP,3,1000) + + + CALL GETENERGY(CHAINP,NEWENERGY) + ! DO C = 1,CHAINP%NPT-1 + ! PRINT*, CHAINP%LS(C), CHAINP%LP(C), CHAINP%BEADENERGY(C+1) + ! ENDDO + + + PRINT*, NEWENERGY + + CALL OUTPUTSNAPSHOT(CHAINP,'finish.out',0,.FALSE.) + END SUBROUTINE CHECKMINIMONTECARLO + + + SUBROUTINE CHECKCUBICROOT + ! check cubic root finder + USE REDISC + IMPLICIT NONE + DOUBLE PRECISION :: ROOT + LOGICAL :: SUCCESS + + CALL CUBICROOT((/1D0,1D0,2D0,4D0/),(/-3D0,-1D0/),ROOT,SUCCESS) + PRINT*, ROOT, SUCCESS + END SUBROUTINE CHECKCUBICROOT + + SUBROUTINE CHECKSPHEREINTERSECT + USE REDISC + IMPLICIT NONE + DOUBLE PRECISION :: PT1(3), PT2(3), PT3(3), RAD1, RAD2, RAD3 + LOGICAL :: INTERSECT + + ! check code for intersection of 3 spheres + RAD1 = 1; RAD2 = 1; RAD3 = 1 + PT1 = (/0D0,0D0,0D0/) + PT2 = (/0D0,0.5D0,0D0/) + PT3 = (/0D0,0D0,0.5D0/) + + CALL INTERSECT3SPHERE(PT1,PT2,PT3,RAD1,RAD2,RAD3,INTERSECT) + + PRINT*, INTERSECT + + END SUBROUTINE CHECKSPHEREINTERSECT + + SUBROUTINE CHECKparamDATA + ! test reading in of parameter data array + ! and interpolation + USE CHAINUTIL + USE KEYS + USE REDISC + USE GENUTIL + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: CHAINP + INTEGER :: C, IND + DOUBLE PRECISION :: DEL, INTERP(6), FRAC + + CHAINP=>WLC + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + + CALL READPARAMDATA('shearWLCparams.data') + + DO C = 1,NPARAMDATA + PRINT*, PARAMDATA(C,:) + ENDDO + + ! Interpolate data + DEL = 0.25D0 + CALL INTERPARRAY(PARAMDATA,(/NPARAMDATA,6/),1,DEL,IND,INTERP) + PRINT*, IND + PRINT*, INTERP + END SUBROUTINE CHECKPARAMDATA + + SUBROUTINE TESTCHAINFORCE + ! test calculation of chain forces + USE CHAINUTIL + USE KEYS + USE BROWNDYN + IMPLICIT NONE + TYPE(CHAIN), TARGET :: WLC + TYPE(OBSTACLE), TARGET :: OB + TYPE(CHAIN), POINTER :: CHAINP + TYPE(OBSTACLE), POINTER :: OBP + DOUBLE PRECISION :: ENERGY, ENERGY0 + DOUBLE PRECISION, ALLOCATABLE :: RFORCE(:,:),RFORCETMP(:,:),UFORCE(:,:),UFORCETMP(:,:),BROWNPOS(:,:) + DOUBLE PRECISION, PARAMETER :: TINY = 1D-7 + ! DOUBLE PRECISION :: OBSTPOS(3), OBSTRAD, OBSTMOD + ! DOUBLE PRECISION :: OBFORCE(3),OBFORCETMP(3) + INTEGER :: C, b + + CHAINP=>WLC; !OBP=>OB + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + !CALL SETOBSTACLEPARAMS(OBP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE) + !OBP%COORDS = (/0.1D0,0.2D0,1D0/) + + print*, 'testx1:', chainp%npt + !CALL OUTPUTSNAPSHOT(CHAINP,OUTFILE,1,.FALSE.) + + ALLOCATE(RFORCE(3,CHAINP%NPT),RFORCETMP(3,CHAINP%NPT),BROWNPOS(3,CHAINP%NPT)) + ALLOCATE(UFORCE(3,CHAINP%NPT),UFORCETMP(3,CHAINP%NPT)) + + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCE,UFORCE,ENERGY0,.TRUE.) + ELSE + print*, 'NOT SET UP FOR BEADRODFORCE YET' + STOP 1 + !CALL GETBEADRODFORCE(CHAINP,BROWNPOS,RFORCE,ENERGY0) + ENDIF + !CALL GETENERGY(CHAINP,ENERGY0) + ! PRINT*, ENERGY0, ENERGY + + !CALL GETOBSTACLEFORCE(CHAINP,OBP,FORCES,OBFORCE,ENERGY0) + !CALL GETCHAINFORCEGAUSS(CHAINP,RFORCE,ENERGY0) + + DO B = 1,CHAINP%NPT + DO C = 1,3 + CHAINP%POS(C,B) = CHAINP%POS(C,B) + TINY + IF (CHAINP%STRETCHABLE.OR.CHAINP%SHEARABLE) THEN + CALL GETCHAINFORCEINT(CHAINP,RFORCETMP,UFORCETMP,ENERGY,.TRUE.) + ELSE + print*, 'NOT SET UP FOR BEADRODFORCE YET' + STOP 1 + !CALL GETBEADRODFORCE(CHAINP,BROWNPOS,RFORCETMP,ENERGY) + ENDIF + !CALL GETCHAINFORCEINT(CHAINP,RFORCETMP,UFORCETMP,ENERGY) + !CALL GETENERGY(CHAINP,ENERGY) + !CALL GETOBSTACLEFORCE(CHAINP,OBP,FORCESTMP,OBFORCETMP,ENERGY) + !CALL GETCHAINFORCEGAUSS(CHAINP,RFORCETMP,ENERGY) + PRINT*, 'POS', B, C, RFORCE(C,B), (ENERGY-ENERGY0)/TINY + CHAINP%POS(C,B) = CHAINP%POS(C,B) - TINY + ENDDO + ! DO C = 1,3 + ! CHAINP%UVEC(C,B) = CHAINP%UVEC(C,B) + TINY + ! CALL GETCHAINFORCEINT(CHAINP,RFORCETMP,UFORCETMP,ENERGY) + ! CALL GETENERGY(CHAINP,ENERGY) + ! !CALL GETOBSTACLEFORCE(CHAINP,OBP,FORCESTMP,OBFORCETMP,ENERGY) + ! PRINT*, 'UVEC', B, C, UFORCE(C,B), (ENERGY-ENERGY0)/TINY + ! CHAINP%UVEC(C,B) = CHAINP%UVEC(C,B) - TINY + ! ENDDO + END DO + + ! DO B = 1,CHAINP%NPT + ! PRINT*, 'U * UFORCE:', B, DOT_PRODUCT(UFORCE(:,B),CHAINP%UVEC(:,B)) + ! ENDDO + + ! PRINT*, 'FORCE ON OBSTACLE:' + ! DO C = 1,3 + ! OBP%COORDS(C) = OBP%COORDS(C) + TINY + ! CALL GETOBSTACLEFORCE(CHAINP,OBP,FORCESTMP,OBFORCETMP,ENERGY) + ! PRINT*, C, OBFORCE(C), (ENERGY-ENERGY0)/TINY + ! OBP%COORDS(C) = OBP%COORDS(C) - TINY + ! END DO + + !CALL OUTPUTCHAINOBST(CHAINP,OBP,'test.out') + + DEALLOCATE(RFORCE,RFORCETMP,UFORCE,UFORCETMP,BROWNPOS) + END SUBROUTINE TESTCHAINFORCE + + SUBROUTINE TESTCRANK + USE CHAINUTIL + USE KEYS + USE MONTECARLO + USE SAMPLEUTIL + IMPLICIT NONE + + TYPE(CHAIN), TARGET :: WLC + TYPE(CHAIN), POINTER :: CHAINP + DOUBLE PRECISION :: ENERGY, DELE + INTEGER :: B, BPIVOT(2) + DOUBLE PRECISION :: lastcoords(6), ENERGYOLD + DOUBLE PRECISION, ALLOCATABLE :: PREVPOS(:,:) + INTEGER :: CHOOSEB, CT, NFLEXBEAD + + CHAINP=>WLC + + CALL READKEY + + CALL SETUPCHAIN(CHAINP,MAXNPT) + CALL SETCHAINPARAMS(CHAINP) + CALL INITIALIZECHAIN(CHAINP,.TRUE.,INITRANGE(2)) + CALL GETEQUILCHAIN(CHAINP,EQUILSAMPLETYPE,LASTCOORDS) + ! PRINT*, CHAINP%POS + + ALLOCATE(PREVPOS(3,CHAINP%NPT)) + + PREVPOS = CHAINP%POS + CALL GETENERGY(CHAINP,ENERGY) + print*, 'initial energy:,', energy + ! DO B = 1,NPT + ! PRINT*, 'BEAD ENERGY:', B, CHAINP%BEADENERGY(B) + ! ENDDO + ! PRINT*, 'FORCE ENERGY:', CHAINP%FORCEENERGY + + BPIVOT = 0 + !CALL CRANKMOVE1(CHAINP,2*PI,1D0,BPIVOT(1),DELE) + !CALL CRANKMOVE2(CHAINP,2*PI,1D0,BPIVOT(1),DELE) + + NFLEXBEAD = CHAINP%NPT - CHAINP%NFIXBEAD + ! choose which moveable bead to move + ! WARNING: this is really inefficient... + CHOOSEB = FLOOR(GRND()*NFLEXBEAD)+1 + CT=0 + DO B = 1,CHAINP%NPT + IF (.NOT.CHAINP%ISFIXED(B)) THEN + CT = CT + 1 + ENDIF + IF (CT.EQ.CHOOSEB) THEN + BPIVOT(1) = B + EXIT + ENDIF + ENDDO + + CALL LOCALMOVE(CHAINP,INITRANGE(1),INITRANGE(2),BPIVOT(1),.TRUE.,.TRUE.) + ENERGYOLD = CHAINP%BEADENERGY(BPIVOT(1))+CHAINP%BEADENERGY(BPIVOT(1)+1) + CALL GETBEADENERGY(CHAINP,BPIVOT(1),CHAINP%BEADENERGY(BPIVOT(1))) + CALL GETBEADENERGY(CHAINP,BPIVOT(1)+1,CHAINP%BEADENERGY(BPIVOT(1)+1)) + DELE = CHAINP%BEADENERGY(BPIVOT(1))+CHAINP%BEADENERGY(BPIVOT(1)+1) - ENERGYOLD + + PRINT*, ENERGY+DELE + + PRINT*, BPIVOT + + DO B = 1,CHAINP%NPT + PRINT*, B, CHAINP%POS(:,B)-PREVPOS(:,B) + ENDDO + + CALL GETENERGY(CHAINP,ENERGY) + PRINT*, 'NEW ENERGY', ENERGY + ! DO B = 1,NPT + ! PRINT*, 'BEAD ENERGY:', B, CHAINP%BEADENERGY(B) + ! ENDDO + ! PRINT*, 'FORCE ENERGY:', CHAINP%FORCEENERGY + CALL CLEANUPCHAIN(CHAINP) + DEALLOCATE(PREVPOS) + + END SUBROUTINE TESTCRANK +END PROGRAM MAIN diff --git a/BasicWLC/tests/test_sort.f90 b/BasicWLC/tests/test_sort.f90 new file mode 100644 index 00000000..ab867d79 --- /dev/null +++ b/BasicWLC/tests/test_sort.f90 @@ -0,0 +1,19 @@ +! file: test_sort.f +program test_sort +implicit none +integer :: j +integer, parameter :: sp = selected_real_kind(6, 37) +integer, parameter :: dp = selected_real_kind(15, 307) +integer, parameter :: qp = selected_real_kind(33, 4931) +real(dp) :: r_min(3) = (/ 0.2_dp, 0.1_dp, 0.3_dp /) +integer :: ind(3) = (/ 1, 2, 3 /) +integer, parameter :: correct_ind(3) = (/ 2, 1, 3 /) +call sortp_1r8(3, ind, r_min) +do j=1,3 + if (correct_ind(j).ne.ind(j)) then + stop 1 + end if +end do + + +end program diff --git a/BasicWLC/third_party/DGTSL.f b/BasicWLC/third_party/DGTSL.f new file mode 100644 index 00000000..40b2c958 --- /dev/null +++ b/BasicWLC/third_party/DGTSL.f @@ -0,0 +1,135 @@ +*---------------------------------------------------------------* +*DECK DGTSL + SUBROUTINE DGTSL (N, C, D, E, B, INFO) +C***BEGIN PROLOGUE DGTSL +C***PURPOSE Solve a tridiagonal linear system. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A2A +C***TYPE DOUBLE PRECISION (SGTSL-S, DGTSL-D, CGTSL-C) +C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL +C***AUTHOR Dongarra, J., (ANL) +C***DESCRIPTION +C +C DGTSL given a general tridiagonal matrix and a right hand +C side will find the solution. +C +C On Entry +C +C N INTEGER +C is the order of the tridiagonal matrix. +C +C C DOUBLE PRECISION(N) +C is the subdiagonal of the tridiagonal matrix. +C C(2) through C(N) should contain the subdiagonal. +C On output C is destroyed. +C +C D DOUBLE PRECISION(N) +C is the diagonal of the tridiagonal matrix. +C On output D is destroyed. +C +C E DOUBLE PRECISION(N) +C is the superdiagonal of the tridiagonal matrix. +C E(1) through E(N-1) should contain the superdiagonal. +C On output E is destroyed. +C +C B DOUBLE PRECISION(N) +C is the right hand side vector. +C +C On Return +C +C B is the solution vector. +C +C INFO INTEGER +C = 0 normal value. +C = K if the K-th element of the diagonal becomes +C exactly zero. The subroutine returns when +C this is detected. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGTSL + INTEGER N,INFO + DOUBLE PRECISION C(*),D(*),E(*),B(*) +C + INTEGER K,KB,KP1,NM1,NM2 + DOUBLE PRECISION T +C***FIRST EXECUTABLE STATEMENT DGTSL + INFO = 0 + C(1) = D(1) + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 40 + D(1) = E(1) + E(1) = 0.0D0 + E(N) = 0.0D0 +C + DO 30 K = 1, NM1 + KP1 = K + 1 +C +C FIND THE LARGEST OF THE TWO ROWS +C + IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10 +C +C INTERCHANGE ROW +C + T = C(KP1) + C(KP1) = C(K) + C(K) = T + T = D(KP1) + D(KP1) = D(K) + D(K) = T + T = E(KP1) + E(KP1) = E(K) + E(K) = T + T = B(KP1) + B(KP1) = B(K) + B(K) = T + 10 CONTINUE +C +C ZERO ELEMENTS +C + IF (C(K) .NE. 0.0D0) GO TO 20 + INFO = K + GO TO 100 + 20 CONTINUE + T = -C(KP1)/C(K) + C(KP1) = D(KP1) + T*D(K) + D(KP1) = E(KP1) + T*E(K) + E(KP1) = 0.0D0 + B(KP1) = B(KP1) + T*B(K) + 30 CONTINUE + 40 CONTINUE + IF (C(N) .NE. 0.0D0) GO TO 50 + INFO = N + GO TO 90 + 50 CONTINUE +C +C BACK SOLVE +C + NM2 = N - 2 + B(N) = B(N)/C(N) + IF (N .EQ. 1) GO TO 80 + B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) + IF (NM2 .LT. 1) GO TO 70 + DO 60 KB = 1, NM2 + K = NM2 - KB + 1 + B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE +C + RETURN + END + +*---------------------------------------------------------------* \ No newline at end of file diff --git a/BasicWLC/third_party/dgtsv.f b/BasicWLC/third_party/dgtsv.f new file mode 100644 index 00000000..f6f414da --- /dev/null +++ b/BasicWLC/third_party/dgtsv.f @@ -0,0 +1,263 @@ + SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) +* .. +* +* Purpose +* ======= +* +* DGTSV solves the equation +* +* A*X = B, +* +* where A is an n by n tridiagonal matrix, by Gaussian elimination with +* partial pivoting. +* +* Note that the equation A**T*X = B may be solved by interchanging the +* order of the arguments DU and DL. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* DL (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, DL must contain the (n-1) sub-diagonal elements of +* A. +* +* On exit, DL is overwritten by the (n-2) elements of the +* second super-diagonal of the upper triangular matrix U from +* the LU factorization of A, in DL(1), ..., DL(n-2). +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, D must contain the diagonal elements of A. +* +* On exit, D is overwritten by the n diagonal elements of U. +* +* DU (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, DU must contain the (n-1) super-diagonal elements +* of A. +* +* On exit, DU is overwritten by the (n-1) elements of the first +* super-diagonal of U. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N by NRHS matrix of right hand side matrix B. +* On exit, if INFO = 0, the N by NRHS solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero, and the solution +* has not been computed. The factorization has not been +* completed unless i = N. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION FACT, TEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Subroutines .. +! EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF +! IF( INFO.NE.0 ) THEN +! CALL XERBLA( 'DGTSV ', -INFO ) +! RETURN +! END IF +* + IF( N.EQ.0 ) + $ RETURN +* + IF( NRHS.EQ.1 ) THEN + DO 10 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN +* +* No row interchange required +* + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) + ELSE + INFO = I + RETURN + END IF + DL( I ) = ZERO + ELSE +* +* Interchange rows I and I+1 +* + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DL( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DL( I ) + DU( I ) = TEMP + TEMP = B( I, 1 ) + B( I, 1 ) = B( I+1, 1 ) + B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) + END IF + 10 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) + ELSE + INFO = I + RETURN + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DU( I ) = TEMP + TEMP = B( I, 1 ) + B( I, 1 ) = B( I+1, 1 ) + B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) + END IF + END IF + IF( D( N ).EQ.ZERO ) THEN + INFO = N + RETURN + END IF + ELSE + DO 40 I = 1, N - 2 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN +* +* No row interchange required +* + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + DO 20 J = 1, NRHS + B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) + 20 CONTINUE + ELSE + INFO = I + RETURN + END IF + DL( I ) = ZERO + ELSE +* +* Interchange rows I and I+1 +* + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DL( I ) = DU( I+1 ) + DU( I+1 ) = -FACT*DL( I ) + DU( I ) = TEMP + DO 30 J = 1, NRHS + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - FACT*B( I+1, J ) + 30 CONTINUE + END IF + 40 CONTINUE + IF( N.GT.1 ) THEN + I = N - 1 + IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN + IF( D( I ).NE.ZERO ) THEN + FACT = DL( I ) / D( I ) + D( I+1 ) = D( I+1 ) - FACT*DU( I ) + DO 50 J = 1, NRHS + B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) + 50 CONTINUE + ELSE + INFO = I + RETURN + END IF + ELSE + FACT = D( I ) / DL( I ) + D( I ) = DL( I ) + TEMP = D( I+1 ) + D( I+1 ) = DU( I ) - FACT*TEMP + DU( I ) = TEMP + DO 60 J = 1, NRHS + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - FACT*B( I+1, J ) + 60 CONTINUE + END IF + END IF + IF( D( N ).EQ.ZERO ) THEN + INFO = N + RETURN + END IF + END IF +* +* Back solve with the matrix U from the factorization. +* + IF( NRHS.LE.2 ) THEN + J = 1 + 70 CONTINUE + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 ) + DO 80 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* + $ B( I+2, J ) ) / D( I ) + 80 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 70 + END IF + ELSE + DO 100 J = 1, NRHS + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 90 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* + $ B( I+2, J ) ) / D( I ) + 90 CONTINUE + 100 CONTINUE + END IF +* + RETURN +* +* End of DGTSV +* + END diff --git a/BasicWLC/third_party/kdtree2.f90 b/BasicWLC/third_party/kdtree2.f90 new file mode 100644 index 00000000..4db279fb --- /dev/null +++ b/BasicWLC/third_party/kdtree2.f90 @@ -0,0 +1,1901 @@ +! +!(c) Matthew Kennel, Institute for Nonlinear Science (2004) +! +! Licensed under the Academic Free License version 1.1 found in file LICENSE +! with additional provisions found in that same file. +! +module kdtree2_precision_module + + integer, parameter :: sp = kind(0.0) + integer, parameter :: dp = kind(0.0d0) + + private :: sp, dp + + ! + ! You must comment out exactly one + ! of the two lines. If you comment + ! out kdkind = sp then you get single precision + ! and if you comment out kdkind = dp + ! you get double precision. + ! + +! integer, parameter :: kdkind = sp + integer, parameter :: kdkind = dp + public :: kdkind + +end module kdtree2_precision_module + +module kdtree2_priority_queue_module + use kdtree2_precision_module + ! + ! maintain a priority queue (PQ) of data, pairs of 'priority/payload', + ! implemented with a binary heap. This is the type, and the 'dis' field + ! is the priority. + ! + type kdtree2_result + ! a pair of distances, indexes + real(kdkind) :: dis!=0.0 + integer :: idx!=-1 Initializers cause some bugs in compilers. + end type kdtree2_result + ! + ! A heap-based priority queue lets one efficiently implement the following + ! operations, each in log(N) time, as opposed to linear time. + ! + ! 1) add a datum (push a datum onto the queue, increasing its length) + ! 2) return the priority value of the maximum priority element + ! 3) pop-off (and delete) the element with the maximum priority, decreasing + ! the size of the queue. + ! 4) replace the datum with the maximum priority with a supplied datum + ! (of either higher or lower priority), maintaining the size of the + ! queue. + ! + ! + ! In the k-d tree case, the 'priority' is the square distance of a point in + ! the data set to a reference point. The goal is to keep the smallest M + ! distances to a reference point. The tree algorithm searches terminal + ! nodes to decide whether to add points under consideration. + ! + ! A priority queue is useful here because it lets one quickly return the + ! largest distance currently existing in the list. If a new candidate + ! distance is smaller than this, then the new candidate ought to replace + ! the old candidate. In priority queue terms, this means removing the + ! highest priority element, and inserting the new one. + ! + ! Algorithms based on Cormen, Leiserson, Rivest, _Introduction + ! to Algorithms_, 1990, with further optimization by the author. + ! + ! Originally informed by a C implementation by Sriranga Veeraraghavan. + ! + ! This module is not written in the most clear way, but is implemented such + ! for speed, as it its operations will be called many times during searches + ! of large numbers of neighbors. + ! + type pq + ! + ! The priority queue consists of elements + ! priority(1:heap_size), with associated payload(:). + ! + ! There are heap_size active elements. + ! Assumes the allocation is always sufficient. Will NOT increase it + ! to match. + integer :: heap_size = 0 + type(kdtree2_result), pointer :: elems(:) + end type pq + + public :: kdtree2_result + + public :: pq + public :: pq_create + public :: pq_delete, pq_insert + public :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri + private + +contains + + + function pq_create(results_in) result(res) + ! + ! Create a priority queue from ALREADY allocated + ! array pointers for storage. NOTE! It will NOT + ! add any alements to the heap, i.e. any existing + ! data in the input arrays will NOT be used and may + ! be overwritten. + ! + ! usage: + ! real(kdkind), pointer :: x(:) + ! integer, pointer :: k(:) + ! allocate(x(1000),k(1000)) + ! pq => pq_create(x,k) + ! + type(kdtree2_result), target:: results_in(:) + type(pq) :: res + ! + ! + integer :: nalloc + + nalloc = size(results_in,1) + if (nalloc .lt. 1) then + write (*,*) 'PQ_CREATE: error, input arrays must be allocated.' + end if + res%elems => results_in + res%heap_size = 0 + return + end function pq_create + + ! + ! operations for getting parents and left + right children + ! of elements in a binary heap. + ! + +! +! These are written inline for speed. +! +! integer function parent(i) +! integer, intent(in) :: i +! parent = (i/2) +! return +! end function parent + +! integer function left(i) +! integer, intent(in) ::i +! left = (2*i) +! return +! end function left + +! integer function right(i) +! integer, intent(in) :: i +! right = (2*i)+1 +! return +! end function right + +! logical function compare_priority(p1,p2) +! real(kdkind), intent(in) :: p1, p2 +! +! compare_priority = (p1 .gt. p2) +! return +! end function compare_priority + + subroutine heapify(a,i_in) + ! + ! take a heap rooted at 'i' and force it to be in the + ! heap canonical form. This is performance critical + ! and has been tweaked a little to reflect this. + ! + type(pq),pointer :: a + integer, intent(in) :: i_in + ! + integer :: i, l, r, largest + + real(kdkind) :: pri_i, pri_l, pri_r, pri_largest + + + type(kdtree2_result) :: temp + + i = i_in + +bigloop: do + l = 2*i ! left(i) + r = l+1 ! right(i) + ! + ! set 'largest' to the index of either i, l, r + ! depending on whose priority is largest. + ! + ! note that l or r can be larger than the heap size + ! in which case they do not count. + + + ! does left child have higher priority? + if (l .gt. a%heap_size) then + ! we know that i is the largest as both l and r are invalid. + exit + else + pri_i = a%elems(i)%dis + pri_l = a%elems(l)%dis + if (pri_l .gt. pri_i) then + largest = l + pri_largest = pri_l + else + largest = i + pri_largest = pri_i + endif + + ! + ! between i and l we have a winner + ! now choose between that and r. + ! + if (r .le. a%heap_size) then + pri_r = a%elems(r)%dis + if (pri_r .gt. pri_largest) then + largest = r + endif + endif + endif + + if (largest .ne. i) then + ! swap data in nodes largest and i, then heapify + + temp = a%elems(i) + a%elems(i) = a%elems(largest) + a%elems(largest) = temp + ! + ! Canonical heapify() algorithm has tail-ecursive call: + ! + ! call heapify(a,largest) + ! we will simulate with cycle + ! + i = largest + cycle bigloop ! continue the loop + else + return ! break from the loop + end if + enddo bigloop + return + end subroutine heapify + + subroutine pq_max(a,e) + ! + ! return the priority and its payload of the maximum priority element + ! on the queue, which should be the first one, if it is + ! in heapified form. + ! + type(pq),pointer :: a + type(kdtree2_result),intent(out) :: e + + if (a%heap_size .gt. 0) then + e = a%elems(1) + else + write (*,*) 'PQ_MAX: ERROR, heap_size < 1' + stop + endif + return + end subroutine pq_max + + real(kdkind) function pq_maxpri(a) + type(pq), pointer :: a + + if (a%heap_size .gt. 0) then + pq_maxpri = a%elems(1)%dis + else + write (*,*) 'PQ_MAX_PRI: ERROR, heapsize < 1' + stop + endif + return + end function pq_maxpri + + subroutine pq_extract_max(a,e) + ! + ! return the priority and payload of maximum priority + ! element, and remove it from the queue. + ! (equivalent to 'pop()' on a stack) + ! + type(pq),pointer :: a + type(kdtree2_result), intent(out) :: e + + if (a%heap_size .ge. 1) then + ! + ! return max as first element + ! + e = a%elems(1) + + ! + ! move last element to first + ! + a%elems(1) = a%elems(a%heap_size) + a%heap_size = a%heap_size-1 + call heapify(a,1) + return + else + write (*,*) 'PQ_EXTRACT_MAX: error, attempted to pop non-positive PQ' + stop + end if + + end subroutine pq_extract_max + + + real(kdkind) function pq_insert(a,dis,idx) + ! + ! Insert a new element and return the new maximum priority, + ! which may or may not be the same as the old maximum priority. + ! + type(pq),pointer :: a + real(kdkind), intent(in) :: dis + integer, intent(in) :: idx + ! type(kdtree2_result), intent(in) :: e + ! + integer :: i, isparent + real(kdkind) :: parentdis + ! + + ! if (a%heap_size .ge. a%max_elems) then + ! write (*,*) 'PQ_INSERT: error, attempt made to insert element on full PQ' + ! stop + ! else + a%heap_size = a%heap_size + 1 + i = a%heap_size + + do while (i .gt. 1) + isparent = int(i/2) + parentdis = a%elems(isparent)%dis + if (dis .gt. parentdis) then + ! move what was in i's parent into i. + a%elems(i)%dis = parentdis + a%elems(i)%idx = a%elems(isparent)%idx + i = isparent + else + exit + endif + end do + + ! insert the element at the determined position + a%elems(i)%dis = dis + a%elems(i)%idx = idx + + pq_insert = a%elems(1)%dis + return + ! end if + + end function pq_insert + + subroutine pq_adjust_heap(a,i) + type(pq),pointer :: a + integer, intent(in) :: i + ! + ! nominally arguments (a,i), but specialize for a=1 + ! + ! This routine assumes that the trees with roots 2 and 3 are already heaps, i.e. + ! the children of '1' are heaps. When the procedure is completed, the + ! tree rooted at 1 is a heap. + real(kdkind) :: prichild + integer :: parent, child, N + + type(kdtree2_result) :: e + + e = a%elems(i) + + parent = i + child = 2*i + N = a%heap_size + + do while (child .le. N) + if (child .lt. N) then + if (a%elems(child)%dis .lt. a%elems(child+1)%dis) then + child = child+1 + endif + endif + prichild = a%elems(child)%dis + if (e%dis .ge. prichild) then + exit + else + ! move child into parent. + a%elems(parent) = a%elems(child) + parent = child + child = 2*parent + end if + end do + a%elems(parent) = e + return + end subroutine pq_adjust_heap + + + real(kdkind) function pq_replace_max(a,dis,idx) + ! + ! Replace the extant maximum priority element + ! in the PQ with (dis,idx). Return + ! the new maximum priority, which may be larger + ! or smaller than the old one. + ! + type(pq),pointer :: a + real(kdkind), intent(in) :: dis + integer, intent(in) :: idx +! type(kdtree2_result), intent(in) :: e + ! not tested as well! + + integer :: parent, child, N + real(kdkind) :: prichild, prichildp1 + + type(kdtree2_result) :: etmp + + if (.true.) then + N=a%heap_size + if (N .ge. 1) then + parent =1 + child=2 + + loop: do while (child .le. N) + prichild = a%elems(child)%dis + + ! + ! posibly child+1 has higher priority, and if + ! so, get it, and increment child. + ! + + if (child .lt. N) then + prichildp1 = a%elems(child+1)%dis + if (prichild .lt. prichildp1) then + child = child+1 + prichild = prichildp1 + endif + endif + + if (dis .ge. prichild) then + exit loop + ! we have a proper place for our new element, + ! bigger than either children's priority. + else + ! move child into parent. + a%elems(parent) = a%elems(child) + parent = child + child = 2*parent + end if + end do loop + a%elems(parent)%dis = dis + a%elems(parent)%idx = idx + pq_replace_max = a%elems(1)%dis + else + a%elems(1)%dis = dis + a%elems(1)%idx = idx + pq_replace_max = dis + endif + else + ! + ! slower version using elementary pop and push operations. + ! + call pq_extract_max(a,etmp) + etmp%dis = dis + etmp%idx = idx + pq_replace_max = pq_insert(a,dis,idx) + endif + return + end function pq_replace_max + + subroutine pq_delete(a,i) + ! + ! delete item with index 'i' + ! + type(pq),pointer :: a + integer :: i + + if ((i .lt. 1) .or. (i .gt. a%heap_size)) then + write (*,*) 'PQ_DELETE: error, attempt to remove out of bounds element.' + stop + endif + + ! swap the item to be deleted with the last element + ! and shorten heap by one. + a%elems(i) = a%elems(a%heap_size) + a%heap_size = a%heap_size - 1 + + call heapify(a,i) + + end subroutine pq_delete + +end module kdtree2_priority_queue_module + + +module kdtree2_module + use kdtree2_precision_module + use kdtree2_priority_queue_module + ! K-D tree routines in Fortran 90 by Matt Kennel. + ! Original program was written in Sather by Steve Omohundro and + ! Matt Kennel. Only the Euclidean metric is supported. + ! + ! + ! This module is identical to 'kd_tree', except that the order + ! of subscripts is reversed in the data file. + ! In otherwords for an embedding of N D-dimensional vectors, the + ! data file is here, in natural Fortran order data(1:D, 1:N) + ! because Fortran lays out columns first, + ! + ! whereas conventionally (C-style) it is data(1:N,1:D) + ! as in the original kd_tree module. + ! + !-------------DATA TYPE, CREATION, DELETION--------------------- + public :: kdkind + public :: kdtree2, kdtree2_result, tree_node, kdtree2_create, kdtree2_destroy + !--------------------------------------------------------------- + !-------------------SEARCH ROUTINES----------------------------- + public :: kdtree2_n_nearest,kdtree2_n_nearest_around_point + ! Return fixed number of nearest neighbors around arbitrary vector, + ! or extant point in dataset, with decorrelation window. + ! + public :: kdtree2_r_nearest, kdtree2_r_nearest_around_point + ! Return points within a fixed ball of arb vector/extant point + ! + public :: kdtree2_sort_results + ! Sort, in order of increasing distance, rseults from above. + ! + public :: kdtree2_r_count, kdtree2_r_count_around_point + ! Count points within a fixed ball of arb vector/extant point + ! + public :: kdtree2_n_nearest_brute_force, kdtree2_r_nearest_brute_force + ! brute force of kdtree2_[n|r]_nearest + !---------------------------------------------------------------- + + + integer, parameter :: bucket_size = 12 + ! The maximum number of points to keep in a terminal node. + + type interval + real(kdkind) :: lower,upper + end type interval + + type :: tree_node + ! an internal tree node + private + integer :: cut_dim + ! the dimension to cut + real(kdkind) :: cut_val + ! where to cut the dimension + real(kdkind) :: cut_val_left, cut_val_right + ! improved cutoffs knowing the spread in child boxes. + integer :: l, u + type (tree_node), pointer :: left, right + type(interval), pointer :: box(:) => null() + ! child pointers + ! Points included in this node are indexes[k] with k \in [l,u] + + + end type tree_node + + type :: kdtree2 + ! Global information about the tree, one per tree + integer :: dimen=0, n=0 + ! dimensionality and total # of points + real(kdkind), pointer :: the_data(:,:) => null() + ! pointer to the actual data array + ! + ! IMPORTANT NOTE: IT IS DIMENSIONED the_data(1:d,1:N) + ! which may be opposite of what may be conventional. + ! This is, because in Fortran, the memory layout is such that + ! the first dimension is in sequential order. Hence, with + ! (1:d,1:N), all components of the vector will be in consecutive + ! memory locations. The search time is dominated by the + ! evaluation of distances in the terminal nodes. Putting all + ! vector components in consecutive memory location improves + ! memory cache locality, and hence search speed, and may enable + ! vectorization on some processors and compilers. + + integer, pointer :: ind(:) => null() + ! permuted index into the data, so that indexes[l..u] of some + ! bucket represent the indexes of the actual points in that + ! bucket. + logical :: sort = .false. + ! do we always sort output results? + logical :: rearrange = .false. + real(kdkind), pointer :: rearranged_data(:,:) => null() + ! if (rearrange .eqv. .true.) then rearranged_data has been + ! created so that rearranged_data(:,i) = the_data(:,ind(i)), + ! permitting search to use more cache-friendly rearranged_data, at + ! some initial computation and storage cost. + type (tree_node), pointer :: root => null() + ! root pointer of the tree + end type kdtree2 + + + type :: tree_search_record + ! + ! One of these is created for each search. + ! + private + ! + ! Many fields are copied from the tree structure, in order to + ! speed up the search. + ! + integer :: dimen + integer :: nn, nfound + real(kdkind) :: ballsize + integer :: centeridx=999, correltime=9999 + ! exclude points within 'correltime' of 'centeridx', iff centeridx >= 0 + integer :: nalloc ! how much allocated for results(:)? + logical :: rearrange ! are the data rearranged or original? + ! did the # of points found overflow the storage provided? + logical :: overflow + real(kdkind), pointer :: qv(:) ! query vector + type(kdtree2_result), pointer :: results(:) ! results + type(pq) :: pq + real(kdkind), pointer :: data(:,:) ! temp pointer to data + integer, pointer :: ind(:) ! temp pointer to indexes + end type tree_search_record + + private + ! everything else is private. + + type(tree_search_record), save, target :: sr ! A GLOBAL VARIABLE for search + +contains + + function kdtree2_create(input_data,dim,sort,rearrange) result (mr) + ! + ! create the actual tree structure, given an input array of data. + ! + ! Note, input data is input_data(1:d,1:N), NOT the other way around. + ! THIS IS THE REVERSE OF THE PREVIOUS VERSION OF THIS MODULE. + ! The reason for it is cache friendliness, improving performance. + ! + ! Optional arguments: If 'dim' is specified, then the tree + ! will only search the first 'dim' components + ! of input_data, otherwise, dim is inferred + ! from SIZE(input_data,1). + ! + ! if sort .eqv. .true. then output results + ! will be sorted by increasing distance. + ! default=.false., as it is faster to not sort. + ! + ! if rearrange .eqv. .true. then an internal + ! copy of the data, rearranged by terminal node, + ! will be made for cache friendliness. + ! default=.true., as it speeds searches, but + ! building takes longer, and extra memory is used. + ! + ! .. Function Return Cut_value .. + type (kdtree2), pointer :: mr + integer, intent(in), optional :: dim + logical, intent(in), optional :: sort + logical, intent(in), optional :: rearrange + ! .. + ! .. Array Arguments .. + real(kdkind), target :: input_data(:,:) + ! + integer :: i + ! .. + allocate (mr) + mr%the_data => input_data + ! pointer assignment + + if (present(dim)) then + mr%dimen = dim + else + mr%dimen = size(input_data,1) + end if + mr%n = size(input_data,2) + + if (mr%dimen > mr%n) then + ! unlikely to be correct + write (*,*) 'KD_TREE_TRANS: likely user error.' + write (*,*) 'KD_TREE_TRANS: You passed in matrix with D=',mr%dimen + write (*,*) 'KD_TREE_TRANS: and N=',mr%n + write (*,*) 'KD_TREE_TRANS: note, that new format is data(1:D,1:N)' + write (*,*) 'KD_TREE_TRANS: with usually N >> D. If N =approx= D, then a k-d tree' + write (*,*) 'KD_TREE_TRANS: is not an appropriate data structure.' + stop + end if + + call build_tree(mr) + + if (present(sort)) then + mr%sort = sort + else + mr%sort = .false. + endif + + if (present(rearrange)) then + mr%rearrange = rearrange + else + mr%rearrange = .true. + endif + + if (mr%rearrange) then + allocate(mr%rearranged_data(mr%dimen,mr%n)) + do i=1,mr%n + mr%rearranged_data(:,i) = mr%the_data(:, & + mr%ind(i)) + enddo + else + nullify(mr%rearranged_data) + endif + + end function kdtree2_create + + subroutine build_tree(tp) + type (kdtree2), pointer :: tp + ! .. + integer :: j + type(tree_node), pointer :: dummy => null() + ! .. + allocate (tp%ind(tp%n)) + forall (j=1:tp%n) + tp%ind(j) = j + end forall + tp%root => build_tree_for_range(tp,1,tp%n, dummy) + end subroutine build_tree + + recursive function build_tree_for_range(tp,l,u,parent) result (res) + ! .. Function Return Cut_value .. + type (tree_node), pointer :: res + ! .. + ! .. Structure Arguments .. + type (kdtree2), pointer :: tp + type (tree_node),pointer :: parent + ! .. + ! .. Scalar Arguments .. + integer, intent (In) :: l, u + ! .. + ! .. Local Scalars .. + integer :: i, c, m, dimen + logical :: recompute + real(kdkind) :: average + +!!$ If (.False.) Then +!!$ If ((l .Lt. 1) .Or. (l .Gt. tp%n)) Then +!!$ Stop 'illegal L value in build_tree_for_range' +!!$ End If +!!$ If ((u .Lt. 1) .Or. (u .Gt. tp%n)) Then +!!$ Stop 'illegal u value in build_tree_for_range' +!!$ End If +!!$ If (u .Lt. l) Then +!!$ Stop 'U is less than L, thats illegal.' +!!$ End If +!!$ Endif +!!$ + ! first compute min and max + dimen = tp%dimen + allocate (res) + allocate(res%box(dimen)) + + ! First, compute an APPROXIMATE bounding box of all points associated with this node. + if ( u < l ) then + ! no points in this box + nullify(res) + return + end if + + if ((u-l)<=bucket_size) then + ! + ! always compute true bounding box for terminal nodes. + ! + do i=1,dimen + call spread_in_coordinate(tp,i,l,u,res%box(i)) + end do + res%cut_dim = 0 + res%cut_val = 0.0 + res%l = l + res%u = u + res%left =>null() + res%right => null() + else + ! + ! modify approximate bounding box. This will be an + ! overestimate of the true bounding box, as we are only recomputing + ! the bounding box for the dimension that the parent split on. + ! + ! Going to a true bounding box computation would significantly + ! increase the time necessary to build the tree, and usually + ! has only a very small difference. This box is not used + ! for searching but only for deciding which coordinate to split on. + ! + do i=1,dimen + recompute=.true. + if (associated(parent)) then + if (i .ne. parent%cut_dim) then + recompute=.false. + end if + endif + if (recompute) then + call spread_in_coordinate(tp,i,l,u,res%box(i)) + else + res%box(i) = parent%box(i) + endif + end do + + + c = maxloc(res%box(1:dimen)%upper-res%box(1:dimen)%lower,1) + ! + ! c is the identity of which coordinate has the greatest spread. + ! + + if (.false.) then + ! select exact median to have fully balanced tree. + m = (l+u)/2 + call select_on_coordinate(tp%the_data,tp%ind,c,m,l,u) + else + ! + ! select point halfway between min and max, as per A. Moore, + ! who says this helps in some degenerate cases, or + ! actual arithmetic average. + ! + if (.true.) then + ! actually compute average + average = sum(tp%the_data(c,tp%ind(l:u))) / real(u-l+1,kdkind) + else + average = (res%box(c)%upper + res%box(c)%lower)/2.0 + endif + + res%cut_val = average + m = select_on_coordinate_value(tp%the_data,tp%ind,c,average,l,u) + endif + + ! moves indexes around + res%cut_dim = c + res%l = l + res%u = u +! res%cut_val = tp%the_data(c,tp%ind(m)) + + res%left => build_tree_for_range(tp,l,m,res) + res%right => build_tree_for_range(tp,m+1,u,res) + + if (associated(res%right) .eqv. .false.) then + res%box = res%left%box + res%cut_val_left = res%left%box(c)%upper + res%cut_val = res%cut_val_left + elseif (associated(res%left) .eqv. .false.) then + res%box = res%right%box + res%cut_val_right = res%right%box(c)%lower + res%cut_val = res%cut_val_right + else + res%cut_val_right = res%right%box(c)%lower + res%cut_val_left = res%left%box(c)%upper + res%cut_val = (res%cut_val_left + res%cut_val_right)/2 + + + ! now remake the true bounding box for self. + ! Since we are taking unions (in effect) of a tree structure, + ! this is much faster than doing an exhaustive + ! search over all points + res%box%upper = max(res%left%box%upper,res%right%box%upper) + res%box%lower = min(res%left%box%lower,res%right%box%lower) + endif + end if + end function build_tree_for_range + + integer function select_on_coordinate_value(v,ind,c,alpha,li,ui) & + result(res) + ! Move elts of ind around between l and u, so that all points + ! <= than alpha (in c cooordinate) are first, and then + ! all points > alpha are second. + + ! + ! Algorithm (matt kennel). + ! + ! Consider the list as having three parts: on the left, + ! the points known to be <= alpha. On the right, the points + ! known to be > alpha, and in the middle, the currently unknown + ! points. The algorithm is to scan the unknown points, starting + ! from the left, and swapping them so that they are added to + ! the left stack or the right stack, as appropriate. + ! + ! The algorithm finishes when the unknown stack is empty. + ! + ! .. Scalar Arguments .. + integer, intent (In) :: c, li, ui + real(kdkind), intent(in) :: alpha + ! .. + real(kdkind) :: v(1:,1:) + integer :: ind(1:) + integer :: tmp + ! .. + integer :: lb, rb + ! + ! The points known to be <= alpha are in + ! [l,lb-1] + ! + ! The points known to be > alpha are in + ! [rb+1,u]. + ! + ! Therefore we add new points into lb or + ! rb as appropriate. When lb=rb + ! we are done. We return the location of the last point <= alpha. + ! + ! + lb = li; rb = ui + + do while (lb < rb) + if ( v(c,ind(lb)) <= alpha ) then + ! it is good where it is. + lb = lb+1 + else + ! swap it with rb. + tmp = ind(lb); ind(lb) = ind(rb); ind(rb) = tmp + rb = rb-1 + endif + end do + + ! now lb .eq. ub + if (v(c,ind(lb)) <= alpha) then + res = lb + else + res = lb-1 + endif + + end function select_on_coordinate_value + + subroutine select_on_coordinate(v,ind,c,k,li,ui) + ! Move elts of ind around between l and u, so that the kth + ! element + ! is >= those below, <= those above, in the coordinate c. + ! .. Scalar Arguments .. + integer, intent (In) :: c, k, li, ui + ! .. + integer :: i, l, m, s, t, u + ! .. + real(kdkind) :: v(:,:) + integer :: ind(:) + ! .. + l = li + u = ui + do while (l=k) u = m - 1 + end do + end subroutine select_on_coordinate + + subroutine spread_in_coordinate(tp,c,l,u,interv) + ! the spread in coordinate 'c', between l and u. + ! + ! Return lower bound in 'smin', and upper in 'smax', + ! .. + ! .. Structure Arguments .. + type (kdtree2), pointer :: tp + type(interval), intent(out) :: interv + ! .. + ! .. Scalar Arguments .. + integer, intent (In) :: c, l, u + ! .. + ! .. Local Scalars .. + real(kdkind) :: last, lmax, lmin, t, smin,smax + integer :: i, ulocal + ! .. + ! .. Local Arrays .. + real(kdkind), pointer :: v(:,:) + integer, pointer :: ind(:) + ! .. + v => tp%the_data(1:,1:) + ind => tp%ind(1:) + smin = v(c,ind(l)) + smax = smin + + ulocal = u + + do i = l + 2, ulocal, 2 + lmin = v(c,ind(i-1)) + lmax = v(c,ind(i)) + if (lmin>lmax) then + t = lmin + lmin = lmax + lmax = t + end if + if (smin>lmin) smin = lmin + if (smaxlast) smin = last + if (smax qv + sr%nn = nn + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + sr%overflow = .false. + + sr%results => results + + sr%nalloc = nn ! will be checked + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + if (tp%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + sr%dimen = tp%dimen + + call validate_query_storage(nn) + sr%pq = pq_create(results) + + call search(tp%root) + + if (tp%sort) then + call kdtree2_sort_results(nn, results) + endif +! deallocate(sr%pqp) + return + end subroutine kdtree2_n_nearest + + subroutine kdtree2_n_nearest_around_point(tp,idxin,correltime,nn,results) + ! Find the 'nn' vectors in the tree nearest to point 'idxin', + ! with correlation window 'correltime', returing results in + ! results(:), which must be pre-allocated upon entry. + type (kdtree2), pointer :: tp + integer, intent (In) :: idxin, correltime, nn + type(kdtree2_result), target :: results(:) + + allocate (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:,idxin) ! copy the vector + sr%ballsize = huge(1.0) ! the largest real(kdkind) number + sr%centeridx = idxin + sr%correltime = correltime + + sr%nn = nn + sr%nfound = 0 + + sr%dimen = tp%dimen + sr%nalloc = nn + + sr%results => results + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + if (sr%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + + call validate_query_storage(nn) + sr%pq = pq_create(results) + + call search(tp%root) + + if (tp%sort) then + call kdtree2_sort_results(nn, results) + endif + deallocate (sr%qv) + return + end subroutine kdtree2_n_nearest_around_point + + subroutine kdtree2_r_nearest(tp,qv,r2,nfound,nalloc,results) + ! find the nearest neighbors to point 'idxin', within SQUARED + ! Euclidean distance 'r2'. Upon ENTRY, nalloc must be the + ! size of memory allocated for results(1:nalloc). Upon + ! EXIT, nfound is the number actually found within the ball. + ! + ! Note that if nfound .gt. nalloc then more neighbors were found + ! than there were storage to store. The resulting list is NOT + ! the smallest ball inside norm r^2 + ! + ! Results are NOT sorted unless tree was created with sort option. + type (kdtree2), pointer :: tp + real(kdkind), target, intent (In) :: qv(:) + real(kdkind), intent(in) :: r2 + integer, intent(out) :: nfound + integer, intent (In) :: nalloc + type(kdtree2_result), target :: results(:) + + ! + sr%qv => qv + sr%ballsize = r2 + sr%nn = 0 ! flag for fixed ball search + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + + sr%results => results + + call validate_query_storage(nalloc) + sr%nalloc = nalloc + sr%overflow = .false. + sr%ind => tp%ind + sr%rearrange= tp%rearrange + + if (tp%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + sr%dimen = tp%dimen + + ! + !sr%dsl = Huge(sr%dsl) ! set to huge positive values + !sr%il = -1 ! set to invalid indexes + ! + + call search(tp%root) + nfound = sr%nfound + if (tp%sort) then + call kdtree2_sort_results(nfound, results) + endif + + if (sr%overflow) then + write (*,*) 'KD_TREE_TRANS: warning! return from kdtree2_r_nearest found more neighbors' + write (*,*) 'KD_TREE_TRANS: than storage was provided for. Answer is NOT smallest ball' + write (*,*) 'KD_TREE_TRANS: with that number of neighbors! I.e. it is wrong.' + endif + + return + end subroutine kdtree2_r_nearest + + subroutine kdtree2_r_nearest_around_point(tp,idxin,correltime,r2,& + nfound,nalloc,results) + ! + ! Like kdtree2_r_nearest, but around a point 'idxin' already existing + ! in the data set. + ! + ! Results are NOT sorted unless tree was created with sort option. + ! + type (kdtree2), pointer :: tp + integer, intent (In) :: idxin, correltime, nalloc + real(kdkind), intent(in) :: r2 + integer, intent(out) :: nfound + type(kdtree2_result), target :: results(:) + ! .. + ! .. Intrinsic Functions .. + intrinsic HUGE + ! .. + allocate (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:,idxin) ! copy the vector + sr%ballsize = r2 + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = idxin + sr%correltime = correltime + + sr%results => results + + sr%nalloc = nalloc + sr%overflow = .false. + + call validate_query_storage(nalloc) + + ! sr%dsl = HUGE(sr%dsl) ! set to huge positive values + ! sr%il = -1 ! set to invalid indexes + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + if (tp%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + sr%rearrange = tp%rearrange + sr%dimen = tp%dimen + + ! + !sr%dsl = Huge(sr%dsl) ! set to huge positive values + !sr%il = -1 ! set to invalid indexes + ! + + call search(tp%root) + nfound = sr%nfound + if (tp%sort) then + call kdtree2_sort_results(nfound,results) + endif + + if (sr%overflow) then + write (*,*) 'KD_TREE_TRANS: warning! return from kdtree2_r_nearest found more neighbors' + write (*,*) 'KD_TREE_TRANS: than storage was provided for. Answer is NOT smallest ball' + write (*,*) 'KD_TREE_TRANS: with that number of neighbors! I.e. it is wrong.' + endif + + deallocate (sr%qv) + return + end subroutine kdtree2_r_nearest_around_point + + function kdtree2_r_count(tp,qv,r2) result(nfound) + ! Count the number of neighbors within square distance 'r2'. + type (kdtree2), pointer :: tp + real(kdkind), target, intent (In) :: qv(:) + real(kdkind), intent(in) :: r2 + integer :: nfound + ! .. + ! .. Intrinsic Functions .. + intrinsic HUGE + ! .. + sr%qv => qv + sr%ballsize = r2 + + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = -1 + sr%correltime = 0 + + nullify(sr%results) ! for some reason, FTN 95 chokes on '=> null()' + + sr%nalloc = 0 ! we do not allocate any storage but that's OK + ! for counting. + sr%ind => tp%ind + sr%rearrange = tp%rearrange + if (tp%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + sr%dimen = tp%dimen + + ! + !sr%dsl = Huge(sr%dsl) ! set to huge positive values + !sr%il = -1 ! set to invalid indexes + ! + sr%overflow = .false. + + call search(tp%root) + + nfound = sr%nfound + + return + end function kdtree2_r_count + + function kdtree2_r_count_around_point(tp,idxin,correltime,r2) & + result(nfound) + ! Count the number of neighbors within square distance 'r2' around + ! point 'idxin' with decorrelation time 'correltime'. + ! + type (kdtree2), pointer :: tp + integer, intent (In) :: correltime, idxin + real(kdkind), intent(in) :: r2 + integer :: nfound + ! .. + ! .. + ! .. Intrinsic Functions .. + intrinsic HUGE + ! .. + allocate (sr%qv(tp%dimen)) + sr%qv = tp%the_data(:,idxin) + sr%ballsize = r2 + + sr%nn = 0 ! flag for fixed r search + sr%nfound = 0 + sr%centeridx = idxin + sr%correltime = correltime + nullify(sr%results) + + sr%nalloc = 0 ! we do not allocate any storage but that's OK + ! for counting. + + sr%ind => tp%ind + sr%rearrange = tp%rearrange + + if (sr%rearrange) then + sr%Data => tp%rearranged_data + else + sr%Data => tp%the_data + endif + sr%dimen = tp%dimen + + ! + !sr%dsl = Huge(sr%dsl) ! set to huge positive values + !sr%il = -1 ! set to invalid indexes + ! + sr%overflow = .false. + + call search(tp%root) + + nfound = sr%nfound + + return + end function kdtree2_r_count_around_point + + + subroutine validate_query_storage(n) + ! + ! make sure we have enough storage for n + ! + integer, intent(in) :: n + + if (size(sr%results,1) .lt. n) then + write (*,*) 'KD_TREE_TRANS: you did not provide enough storage for results(1:n)' + stop + return + endif + + return + end subroutine validate_query_storage + + function square_distance(d, iv,qv) result (res) + ! distance between iv[1:n] and qv[1:n] + ! .. Function Return Value .. + ! re-implemented to improve vectorization. + real(kdkind) :: res + ! .. + ! .. + ! .. Scalar Arguments .. + integer :: d + ! .. + ! .. Array Arguments .. + real(kdkind) :: iv(:),qv(:) + ! .. + ! .. + res = sum( (iv(1:d)-qv(1:d))**2 ) + end function square_distance + + recursive subroutine search(node) + ! + ! This is the innermost core routine of the kd-tree search. Along + ! with "process_terminal_node", it is the performance bottleneck. + ! + ! This version uses a logically complete secondary search of + ! "box in bounds", whether the sear + ! + type (Tree_node), pointer :: node + ! .. + type(tree_node),pointer :: ncloser, nfarther + ! + integer :: cut_dim, i + ! .. + real(kdkind) :: qval, dis + real(kdkind) :: ballsize + real(kdkind), pointer :: qv(:) + type(interval), pointer :: box(:) + + if ((associated(node%left) .and. associated(node%right)) .eqv. .false.) then + ! we are on a terminal node + if (sr%nn .eq. 0) then + call process_terminal_node_fixedball(node) + else + call process_terminal_node(node) + endif + else + ! we are not on a terminal node + qv => sr%qv(1:) + cut_dim = node%cut_dim + qval = qv(cut_dim) + + if (qval < node%cut_val) then + ncloser => node%left + nfarther => node%right + dis = (node%cut_val_right - qval)**2 +! extra = node%cut_val - qval + else + ncloser => node%right + nfarther => node%left + dis = (node%cut_val_left - qval)**2 +! extra = qval- node%cut_val_left + endif + + if (associated(ncloser)) call search(ncloser) + + ! we may need to search the second node. + if (associated(nfarther)) then + ballsize = sr%ballsize +! dis=extra**2 + if (dis <= ballsize) then + ! + ! we do this separately as going on the first cut dimen is often + ! a good idea. + ! note that if extra**2 < sr%ballsize, then the next + ! check will also be false. + ! + box => node%box(1:) + do i=1,sr%dimen + if (i .ne. cut_dim) then + dis = dis + dis2_from_bnd(qv(i),box(i)%lower,box(i)%upper) + if (dis > ballsize) then + return + endif + endif + end do + + ! + ! if we are still here then we need to search mroe. + ! + call search(nfarther) + endif + endif + end if + end subroutine search + + + real(kdkind) function dis2_from_bnd(x,amin,amax) result (res) + real(kdkind), intent(in) :: x, amin,amax + + if (x > amax) then + res = (x-amax)**2; + return + else + if (x < amin) then + res = (amin-x)**2; + return + else + res = 0.0 + return + endif + endif + return + end function dis2_from_bnd + + logical function box_in_search_range(node, sr) result(res) + ! + ! Return the distance from 'qv' to the CLOSEST corner of node's + ! bounding box + ! for all coordinates outside the box. Coordinates inside the box + ! contribute nothing to the distance. + ! + type (tree_node), pointer :: node + type (tree_search_record), pointer :: sr + + integer :: dimen, i + real(kdkind) :: dis, ballsize + real(kdkind) :: l, u + + dimen = sr%dimen + ballsize = sr%ballsize + dis = 0.0 + res = .true. + do i=1,dimen + l = node%box(i)%lower + u = node%box(i)%upper + dis = dis + (dis2_from_bnd(sr%qv(i),l,u)) + if (dis > ballsize) then + res = .false. + return + endif + end do + res = .true. + return + end function box_in_search_range + + + subroutine process_terminal_node(node) + ! + ! Look for actual near neighbors in 'node', and update + ! the search results on the sr data structure. + ! + type (tree_node), pointer :: node + ! + real(kdkind), pointer :: qv(:) + integer, pointer :: ind(:) + real(kdkind), pointer :: data(:,:) + ! + integer :: dimen, i, indexofi, k, centeridx, correltime + real(kdkind) :: ballsize, sd, newpri + logical :: rearrange + type(pq), pointer :: pqp + ! + ! copy values from sr to local variables + ! + ! + ! Notice, making local pointers with an EXPLICIT lower bound + ! seems to generate faster code. + ! why? I don't know. + qv => sr%qv(1:) + pqp => sr%pq + dimen = sr%dimen + ballsize = sr%ballsize + rearrange = sr%rearrange + ind => sr%ind(1:) + data => sr%Data(1:,1:) + centeridx = sr%centeridx + correltime = sr%correltime + + ! doing_correl = (centeridx >= 0) ! Do we have a decorrelation window? + ! include_point = .true. ! by default include all points + ! search through terminal bucket. + + mainloop: do i = node%l, node%u + if (rearrange) then + sd = 0.0 + do k = 1,dimen + sd = sd + (data(k,i) - qv(k))**2 + if (sd>ballsize) cycle mainloop + end do + indexofi = ind(i) ! only read it if we have not broken out + else + indexofi = ind(i) + sd = 0.0 + do k = 1,dimen + sd = sd + (data(k,indexofi) - qv(k))**2 + if (sd>ballsize) cycle mainloop + end do + endif + + if (centeridx > 0) then ! doing correlation interval? + if (abs(indexofi-centeridx) < correltime) cycle mainloop + endif + + + ! + ! two choices for any point. The list so far is either undersized, + ! or it is not. + ! + ! If it is undersized, then add the point and its distance + ! unconditionally. If the point added fills up the working + ! list then set the sr%ballsize, maximum distance bound (largest distance on + ! list) to be that distance, instead of the initialized +infinity. + ! + ! If the running list is full size, then compute the + ! distance but break out immediately if it is larger + ! than sr%ballsize, "best squared distance" (of the largest element), + ! as it cannot be a good neighbor. + ! + ! Once computed, compare to best_square distance. + ! if it is smaller, then delete the previous largest + ! element and add the new one. + + if (sr%nfound .lt. sr%nn) then + ! + ! add this point unconditionally to fill list. + ! + sr%nfound = sr%nfound +1 + newpri = pq_insert(pqp,sd,indexofi) + if (sr%nfound .eq. sr%nn) ballsize = newpri + ! we have just filled the working list. + ! put the best square distance to the maximum value + ! on the list, which is extractable from the PQ. + + else + ! + ! now, if we get here, + ! we know that the current node has a squared + ! distance smaller than the largest one on the list, and + ! belongs on the list. + ! Hence we replace that with the current one. + ! + ballsize = pq_replace_max(pqp,sd,indexofi) + endif + end do mainloop + ! + ! Reset sr variables which may have changed during loop + ! + sr%ballsize = ballsize + + end subroutine process_terminal_node + + subroutine process_terminal_node_fixedball(node) + ! + ! Look for actual near neighbors in 'node', and update + ! the search results on the sr data structure, i.e. + ! save all within a fixed ball. + ! + type (tree_node), pointer :: node + ! + real(kdkind), pointer :: qv(:) + integer, pointer :: ind(:) + real(kdkind), pointer :: data(:,:) + ! + integer :: nfound + integer :: dimen, i, indexofi, k + integer :: centeridx, correltime, nn + real(kdkind) :: ballsize, sd + logical :: rearrange + + ! + ! copy values from sr to local variables + ! + qv => sr%qv(1:) + dimen = sr%dimen + ballsize = sr%ballsize + rearrange = sr%rearrange + ind => sr%ind(1:) + data => sr%Data(1:,1:) + centeridx = sr%centeridx + correltime = sr%correltime + nn = sr%nn ! number to search for + nfound = sr%nfound + + ! search through terminal bucket. + mainloop: do i = node%l, node%u + + ! + ! two choices for any point. The list so far is either undersized, + ! or it is not. + ! + ! If it is undersized, then add the point and its distance + ! unconditionally. If the point added fills up the working + ! list then set the sr%ballsize, maximum distance bound (largest distance on + ! list) to be that distance, instead of the initialized +infinity. + ! + ! If the running list is full size, then compute the + ! distance but break out immediately if it is larger + ! than sr%ballsize, "best squared distance" (of the largest element), + ! as it cannot be a good neighbor. + ! + ! Once computed, compare to best_square distance. + ! if it is smaller, then delete the previous largest + ! element and add the new one. + + ! which index to the point do we use? + + if (rearrange) then + sd = 0.0 + do k = 1,dimen + sd = sd + (data(k,i) - qv(k))**2 + if (sd>ballsize) cycle mainloop + end do + indexofi = ind(i) ! only read it if we have not broken out + else + indexofi = ind(i) + sd = 0.0 + do k = 1,dimen + sd = sd + (data(k,indexofi) - qv(k))**2 + if (sd>ballsize) cycle mainloop + end do + endif + + if (centeridx > 0) then ! doing correlation interval? + if (abs(indexofi-centeridx) 1)then + ileft=ileft-1 + value=a(ileft); ivalue=ind(ileft) + else + value=a(iright); ivalue=ind(iright) + a(iright)=a(1); ind(iright)=ind(1) + iright=iright-1 + if (iright == 1) then + a(1)=value;ind(1)=ivalue + return + endif + endif + i=ileft + j=2*ileft + do while (j <= iright) + if(j < iright) then + if(a(j) < a(j+1)) j=j+1 + endif + if(value < a(j)) then + a(i)=a(j); ind(i)=ind(j) + i=j + j=j+j + else + j=iright+1 + endif + end do + a(i)=value; ind(i)=ivalue + end do + end subroutine heapsort + + subroutine heapsort_struct(a,n) + ! + ! Sort a(1:n) in ascending order + ! + ! + integer,intent(in) :: n + type(kdtree2_result),intent(inout) :: a(:) + + ! + ! + type(kdtree2_result) :: value ! temporary value + + integer :: i,j + integer :: ileft,iright + + ileft=n/2+1 + iright=n + + ! do i=1,n + ! ind(i)=i + ! Generate initial idum array + ! end do + + if(n.eq.1) return + + do + if(ileft > 1)then + ileft=ileft-1 + value=a(ileft) + else + value=a(iright) + a(iright)=a(1) + iright=iright-1 + if (iright == 1) then + a(1) = value + return + endif + endif + i=ileft + j=2*ileft + do while (j <= iright) + if(j < iright) then + if(a(j)%dis < a(j+1)%dis) j=j+1 + endif + if(value%dis < a(j)%dis) then + a(i)=a(j); + i=j + j=j+j + else + j=iright+1 + endif + end do + a(i)=value + end do + end subroutine heapsort_struct + +end module kdtree2_module + diff --git a/BasicWLC/third_party/mt19937.f90 b/BasicWLC/third_party/mt19937.f90 new file mode 100644 index 00000000..9d4255d4 --- /dev/null +++ b/BasicWLC/third_party/mt19937.f90 @@ -0,0 +1,273 @@ +! A Fortran-program for MT19937: Real number version + +! Code converted using TO_F90 by Alan Miller +! Date: 1999-11-26 Time: 17:09:23 +! Latest revision - 5 February 2002 +! A new seed initialization routine has been added based upon the new +! C version dated 26 January 2002. +! This version assumes that integer overflows do NOT cause crashes. +! This version is compatible with Lahey's ELF90 compiler, +! and should be compatible with most full Fortran 90 or 95 compilers. +! Notice the strange way in which umask is specified for ELF90. + +! genrand() generates one pseudorandom real number (double) which is +! uniformly distributed on [0,1]-interval, for each call. +! sgenrand(seed) set initial values to the working area of 624 words. +! Before genrand(), sgenrand(seed) must be called once. (seed is any 32-bit +! integer except for 0). +! Integer generator is obtained by modifying two lines. +! Coded by Takuji Nishimura, considering the suggestions by +! Topher Cooper and Marc Rieffel in July-Aug. 1997. + +! This library is free software; you can redistribute it and/or modify it +! under the terms of the GNU Library General Public License as published by +! the Free Software Foundation; either version 2 of the License, or (at your +! option) any later version. This library is distributed in the hope that +! it will be useful, but WITHOUT ANY WARRANTY; without even the implied +! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU Library General Public License for more details. +! You should have received a copy of the GNU Library General Public License +! along with this library; if not, write to the Free Foundation, Inc., +! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +! Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. +! When you use this, send an email to: matumoto@math.keio.ac.jp +! with an appropriate reference to your work. + +!*********************************************************************** +! Fortran translation by Hiroshi Takano. Jan. 13, 1999. + +! genrand() -> double precision function grnd() +! sgenrand(seed) -> subroutine sgrnd(seed) +! integer seed + +! This program uses the following standard intrinsics. +! ishft(i,n): If n > 0, shifts bits in i by n positions to left. +! If n < 0, shifts bits in i by n positions to right. +! iand (i,j): Performs logical AND on corresponding bits of i and j. +! ior (i,j): Performs inclusive OR on corresponding bits of i and j. +! ieor (i,j): Performs exclusive OR on corresponding bits of i and j. + +!*********************************************************************** + +MODULE mt19937 +IMPLICIT NONE +INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) + +! Period parameters +INTEGER, PARAMETER :: n = 624, n1 = n+1, m = 397, mata = -1727483681 +! constant vector a +INTEGER, PARAMETER :: umask = -2147483647 - 1 +! most significant w-r bits +INTEGER, PARAMETER :: lmask = 2147483647 +! least significant r bits +! Tempering parameters +INTEGER, PARAMETER :: tmaskb= -1658038656, tmaskc= -272236544 + +! the array for the state vector +INTEGER, SAVE :: mt(0:n-1), mti = n1 +! mti==N+1 means mt[N] is not initialized +LOGICAL, SAVE :: RNORMRESTART = .FALSE. +REAL, SAVE :: RNORMVSAVE, RNORMSLNSAVE + +PRIVATE +PUBLIC :: dp, sgrnd, grnd, init_genrand, rnorm, MT,mti +! efk: global variables to allow restarting of rnorm() calculation from savefile +PUBLIC :: RNORMRESTART, RNORMSLNSAVE, RNORMVSAVE + +CONTAINS + + +SUBROUTINE sgrnd(seed) +! This is the original version of the seeding routine. +! It was replaced in the Japanese version in C on 26 January 2002 +! It is recommended that routine init_genrand is used instead. + +INTEGER, INTENT(IN) :: seed + +! setting initial seeds to mt[N] using the generator Line 25 of Table 1 in +! [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp102] + +mt(0)= IAND(seed, -1) +DO mti=1,n-1 + mt(mti) = IAND(69069 * mt(mti-1), -1) +END DO + +RETURN +END SUBROUTINE sgrnd +!*********************************************************************** + +SUBROUTINE init_genrand(seed) +! This initialization is based upon the multiplier given on p.106 of the +! 3rd edition of Knuth, The Art of Computer Programming Vol. 2. + +! This version assumes that integer overflow does NOT cause a crash. + +INTEGER, INTENT(IN) :: seed + +INTEGER :: latest + +mt(0) = seed +latest = seed +DO mti = 1, n-1 + latest = IEOR( latest, ISHFT( latest, -30 ) ) + latest = latest * 1812433253 + mti + mt(mti) = latest +END DO + +RETURN +END SUBROUTINE init_genrand +!*********************************************************************** + +FUNCTION grndORIG() RESULT(fn_val) +REAL (dp) :: fn_val + +INTEGER, SAVE :: mag01(0:1) = (/ 0, mata /) +! mag01(x) = x * MATA for x=0,1 +INTEGER :: kk, y + +! These statement functions have been replaced with separate functions +! tshftu(y) = ISHFT(y,-11) +! tshfts(y) = ISHFT(y,7) +! tshftt(y) = ISHFT(y,15) +! tshftl(y) = ISHFT(y,-18) + +IF(mti >= n) THEN +! generate N words at one time + IF(mti == n+1) THEN +! if sgrnd() has not been called, + CALL sgrnd(4357) +! a default initial seed is used + END IF + + DO kk = 0, n-m-1 + y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) + mt(kk) = IEOR(IEOR(mt(kk+m), ISHFT(y,-1)),mag01(IAND(y,1))) + END DO + DO kk = n-m, n-2 + y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) + mt(kk) = IEOR(IEOR(mt(kk+(m-n)), ISHFT(y,-1)),mag01(IAND(y,1))) + END DO + y = IOR(IAND(mt(n-1),umask), IAND(mt(0),lmask)) + mt(n-1) = IEOR(IEOR(mt(m-1), ISHFT(y,-1)),mag01(IAND(y,1))) + mti = 0 +END IF + +y = mt(mti) +mti = mti + 1 +y = IEOR(y, tshftu(y)) +y = IEOR(y, IAND(tshfts(y),tmaskb)) +y = IEOR(y, IAND(tshftt(y),tmaskc)) +y = IEOR(y, tshftl(y)) + +IF(y < 0) THEN + fn_val = (DBLE(y) + 2.0D0**32) / (2.0D0**32 - 1.0D0) +ELSE + fn_val = DBLE(y) / (2.0D0**32 - 1.0D0) +END IF + +RETURN +END FUNCTION grndORIG + + +FUNCTION tshftu(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,-11) +RETURN +END FUNCTION tshftu + + +FUNCTION tshfts(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,7) +RETURN +END FUNCTION tshfts + + +FUNCTION tshftt(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,15) +RETURN +END FUNCTION tshftt + + +FUNCTION tshftl(y) RESULT(fn_val) +INTEGER, INTENT(IN) :: y +INTEGER :: fn_val + +fn_val = ISHFT(y,-18) +RETURN +END FUNCTION tshftl + +! EFK: 2009/08/01 converted to use MT19937 random number generator +FUNCTION rnorm() RESULT( fn_val ) + +! Generate a random normal deviate using the polar method. +! Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating +! normal variables', Siam Rev., vol.6, 260-264, 1964. + +IMPLICIT NONE +REAL :: fn_val + +! Local variables + +REAL :: u, sum +REAL, SAVE :: v, sln +LOGICAL, SAVE :: second = .FALSE. +REAL, PARAMETER :: one = 1.0, vsmall = TINY( one ) + +!print*, 'testx0:', second, rnormrestart, v, sln, rnormvsave, rnormslnsave + +IF (second) THEN +! If second, use the second random number generated on last call + + second = .false. + fn_val = v*sln + +ELSE IF (RNORMRESTART) THEN + ! efk: restart from global variables in save file + SECOND = .FALSE. + v = rnormvsave; sln = rnormslnsave + FN_Val = v*sln + RNORMRESTART = .FALSE. +ELSE +! First call; generate a pair of random normals + + second = .true. + DO + U = GRND( ) + V = GRND() + u = SCALE( u, 1 ) - one + v = SCALE( v, 1 ) - one + sum = u*u + v*v + vsmall ! vsmall added to prevent LOG(zero) / zero + IF(sum < one) EXIT + END DO + sln = SQRT(- SCALE( LOG(sum), 1 ) / sum) + fn_val = u*sln +END IF + +RNORMVSAVE = V; RNORMSLNSAVE = SLN; RNORMRESTART = SECOND + +RETURN +END FUNCTION rnorm + +! EFK: 2009/09/03 wrap around GRND so that it does not ever give exactly 0 or 1 +FUNCTION grnd() RESULT(fn_val) + REAL (dp) :: fn_val + + FN_VAL = 0D0 + DO WHILE (FN_VAL.EQ.0D0.OR.FN_VAL.EQ.1D0) + FN_VAL = GRNDORIG() + ENDDO +END FUNCTION grnd + +END MODULE mt19937 + + + diff --git a/BasicWLC/third_party/qsort_inline.inc b/BasicWLC/third_party/qsort_inline.inc new file mode 100644 index 00000000..cb77fcff --- /dev/null +++ b/BasicWLC/third_party/qsort_inline.inc @@ -0,0 +1,190 @@ +!====================================================================== +! Fast in-line QSORT+INSERTION SORT for Fortran. +! Author: Joseph M. Krahn +! FILE: qsort_inline.inc +! PURPOSE: +! Generate a custom array sort procedure for a specific type, +! without the comparison-callback overhead of a generic sort procedure. +! This is essentially the same as an in-line optimization, which generally +! is not feasible for a library-based generic sort procedure. +! +! This implementation is as generic as possible, while avoiding the need +! for a code pre-processor. The success of this approach assumes that +! internal procedures are always in-lined with optimized Fortran compilation. +! +! USAGE: +! This file contains the sort subroutine body. You must supply +! an integer parameter QSORT_THRESHOLD, and internal procedures: +! subroutine INIT() +! logical function LESS_THAN(a,b) +! subroutine SWAP(a,b) +! subroutine RSHIFT(left,right) +! +! Descriptions: +! +! SUBROUTINE INIT() +! Any user initialization code. This is needed because executable +! statements cannot precede this code, which begins with declarations. +! In many cases, this is just an empty procedure. +! +! LOGICAL FUNCTION LESS_THAN(a,b) +! Return TRUE if array member 'a' is less than array member 'b'. +! Only a TRUE value causes a change in sort order. This minimizes data +! manipulation, and maintains the original order for values that are +! equivalent by the sort comparison. It also avoids the need to +! distinguish equality from greater-than. +! +! SUBROUTINE SWAP(A,B) +! Swap array members 'a' and 'b' +! +! SUBROUTINE RSHIFT(LEFT,RIGHT) +! Perform a circular shift of array members LEFT through RIGHT, +! shifting the element at RIGHT back to the position at LEFT. +! +! QSORT_THRESHOLD: +! The QSORT is used down to the QSORT_THRESHOLD size sorted blocks. +! Then insertion sort is used for the remainder, because it is faster +! for small sort ranges. The optimal size is not critical. Most of +! the benefit is in blocks of 8 or less, and values of 16 to 128 +! are generally about equal speed. However, the optimal value +! depends a lot on the hardware and the data being sorted, so this +! is left as a tunable parameter for cases where ther is an +! effect on performance. +! +!--------------------------------------------------------------------- +! NOTES: +! The procedure uses a optimized combination of QSORT and INSERTION +! sorting. The algorithm is based on code used in GLIBC. +! A stack is used in place of recursive calls. The stack size must +! be at least as big as the number of bits in the largest array index. +! +! Sorting vectors of a multidimensional allocatable array can be +! VERY slow. In this case, or with large derived types, it is better +! to sort a simple derived type of key/index pairs, then reorder +! tha actual data using the sorted indices. +! +!--------------------------------------------------------------------- + integer :: stack_top, right_size, left_size + integer :: mid, left, right, low, high + +! A stack of 32 can handle the entire extent of a 32-bit +! index, so this value is fixed. If you have 64-bit indexed +! arrays, which might contain more thant 2^32 elements, this +! should be set to 64. + integer, parameter :: QSORT_STACK_SIZE = 32 + type qsort_stack; integer :: low, high; end type + type(qsort_stack) :: stack(QSORT_STACK_SIZE) + + call init() + + if (array_size > QSORT_THRESHOLD) then + low = 1 + high = array_size + stack_top = 0 + + QSORT_LOOP: & + do + mid = (low + high)/2 + if (LESS_THAN (mid, low)) then + call SWAP(mid,low) + end if + if (LESS_THAN (high, mid)) then + call SWAP(high,mid) + if (LESS_THAN (mid, low)) then + call SWAP(mid,low) + end if + end if + left = low + 1 + right = high - 1 + + COLLAPSE_WALLS: & + do + do while (LESS_THAN (left, mid)) + left=left+1 + end do + do while (LESS_THAN (mid, right)) + right=right-1 + end do + if (left < right) then + call SWAP(left,right) + if (mid == left) then + mid = right + else if (mid == right) then + mid = left + end if + left=left+1 + right=right-1 + else + if (left == right) then + left=left+1 + right=right-1 + end if + exit COLLAPSE_WALLS + end if + end do COLLAPSE_WALLS + +! Set up indices for the next iteration. +! Determine left and right partition sizes. +! Defer partitions smaller than the QSORT_THRESHOLD. +! If both partitions are significant, +! push the larger one onto the stack. + right_size = right - low + left_size = high - left + if (right_size <= QSORT_THRESHOLD) then + if (left_size <= QSORT_THRESHOLD) then + ! Ignore both small partitions: Pop a partition or exit. + if (stack_top<1) exit QSORT_LOOP + low=stack(stack_top)%low; high=stack(stack_top)%high + stack_top=stack_top-1 + else + ! Ignore small left partition. + low = left + end if + else if (left_size <= QSORT_THRESHOLD) then + ! Ignore small right partition. + high = right + else if (right_size > left_size) then + ! Push larger left partition indices. + stack_top=stack_top+1 + stack(stack_top)=qsort_stack(low,right) + low = left + else + ! Push larger right partition indices. + stack_top=stack_top+1 + stack(stack_top)=qsort_stack(left,high) + high = right + end if + end do QSORT_LOOP + end if ! (array_size > QSORT_THRESHOLD) + +! Sort the remaining small partitions using insertion sort, +! which should be faster for partitions smaller than the +! appropriate QSORT_THRESHOLD. + +! First, find smallest element in first QSORT_THRESHOLD and +! place it at the array's beginning. This places a lower +! bound 'guard' position, and speeds up the inner loop +! below, because it will not need a lower-bound test. + low = 1 + high = array_size + +! left is the MIN_LOC index here: + left=low + do right = low+1, min(low+QSORT_THRESHOLD,high) + if (LESS_THAN(right,left)) left=right + end do + if (left/=low) call SWAP(left,low) + +! Insertion sort, from left to right. +! (assuming that the left is the lowest numbered index) + INSERTION_SORT: & + do right = low+2,high + left=right-1 + if (LESS_THAN(right,left)) then + do while (LESS_THAN(right,left-1)) + left=left-1 + end do + call RSHIFT(left,right) + end if + end do INSERTION_SORT +!-------------------------------------------------------------- diff --git a/BasicWLC/third_party/qsort_inline_index.inc b/BasicWLC/third_party/qsort_inline_index.inc new file mode 100644 index 00000000..79e18002 --- /dev/null +++ b/BasicWLC/third_party/qsort_inline_index.inc @@ -0,0 +1,35 @@ +! FILE:qsort_inline_index.inc +! PURPOSE: +! Common internal procedures for sorting by index, for +! use with "qsort_inline.inc". + +! set up initial index: + subroutine init() + integer :: i + do i=1,array_size + index(i)=i + end do + end subroutine init + +! swap indices a,b + subroutine swap(a,b) + integer, intent(in) :: a,b + integer :: hold + hold=index(a) + index(a)=index(b) + index(b)=hold + end subroutine swap + +! circular shift-right by one: + subroutine rshift(left,right) + implicit none + integer, intent(in) :: left, right + integer :: hold, i + hold=index(right) + ! This sytnax is valid, but has poor optimization in GFortran: + ! index(left+1:right)=index(left:right-1) + do i=right,left+1,-1 + index(i)=index(i-1) + end do + index(left)=hold + end subroutine rshift diff --git a/BasicWLC/third_party/sort.f90 b/BasicWLC/third_party/sort.f90 new file mode 100644 index 00000000..3c2880a7 --- /dev/null +++ b/BasicWLC/third_party/sort.f90 @@ -0,0 +1,99 @@ +! FILE: sort.f +! PURPOSE: demonstrate the use of "qsort_inline.inc" and +! "qsort_inline_index.inc". These can be used as specific +! sort procedures under a common SORT generic name. +!--------------------------------------------------------------- +! Sort a string array, with any string length. +subroutine sortp_string(array_size,index,string) + integer, parameter :: QSORT_THRESHOLD = 32 + integer, intent(in) :: array_size + integer, intent(out) :: index(array_size) + character(len=*), intent(in) :: string(array_size) + include "qsort_inline.inc" +contains + include "qsort_inline_index.inc" + logical & + function less_than(a,b) + integer, intent(in) :: a,b + if ( string(index(a)) == string(index(b)) ) then + less_than = ( index(a) < index(b) ) + else + less_than = ( string(index(a)) < string(index(b)) ) + end if + end function less_than +end subroutine sortp_string +!--------------------------------------------------------------- +! Sort an index-array by its double array target +subroutine sortp_1r8(array_size,index,value) + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: QSORT_THRESHOLD = 32 + integer, intent(in) :: array_size + integer, intent(inout) :: index(array_size) + real(dp), intent(in) :: value(array_size) + include "qsort_inline.inc" +contains + include "qsort_inline_index.inc" + logical & + function less_than(a,b) + integer, intent(in) :: a,b + real(dp), parameter :: small=1.0e-15 + if ( abs(value(index(a))-value(index(b))) < small ) then + less_than = index(a) < index(b) + else + less_than = value(index(a)) < value(index(b)) + end if + end function less_than +end subroutine sortp_1r8 +!--------------------------------------------------------------- +! Sort a single-precision real array by index, with a fuzzy equality test +subroutine sortp_1r4(array_size,index,value) + integer, parameter :: QSORT_THRESHOLD = 32 + integer, intent(in) :: array_size + integer, intent(inout) :: index(array_size) + real(4), intent(in) :: value(array_size) + include "qsort_inline.inc" +contains + include "qsort_inline_index.inc" + logical & + function less_than(a,b) + integer, intent(in) :: a,b + real(4), parameter :: small=1.0e-6 + if ( abs(value(index(a))-value(index(b))) < small ) then + less_than = index(a) < index(b) + else + less_than = value(index(a)) < value(index(b)) + end if + end function less_than +end subroutine sortp_1r4 +!--------------------------------------------------------------- +! Sort an array of integers +subroutine sort_1i(array_size,i1) + integer, parameter :: QSORT_THRESHOLD = 32 + integer, intent(in) :: array_size + integer, intent(inout), dimension(array_size) :: i1 + include "qsort_inline.inc" +contains + subroutine init() + end subroutine init + logical & + function less_than(a,b) + integer, intent(in) :: a,b + if ( i1(a) == i1(b) ) then + less_than = a < b + else + less_than = i1(a) < i1(b) + end if + end function less_than + subroutine swap(a,b) + integer, intent(in) :: a,b + integer :: hold + hold=i1(a); i1(a)=i1(b); i1(b)=hold + end subroutine swap +! circular shift-right by one: + subroutine rshift(left,right) + integer, intent(in) :: left, right + integer :: hold + hold=i1(right); i1(left+1:right)=i1(left:right-1); i1(left)=hold + end subroutine rshift +end subroutine sort_1i +!--------------------------------------------------------------- diff --git a/Makefile b/Makefile index a0d7f9e6..40e16e53 100644 --- a/Makefile +++ b/Makefile @@ -21,7 +21,7 @@ DEP_FILE = wlcsim.dep FC = gfortran # compile flags -FCFLAGS = -ggdb -Jsrc -Isrc -Isrc/third_party -cpp #-fcheck=all -Wall -pedantic +FCFLAGS = -ggdb -Jsrc -Isrc -Isrc/third_party -cpp #-fbounds-check #-fcheck=all -Wall -pedantic # link flags FLFLAGS = @@ -31,7 +31,7 @@ FLFLAGS = # depends on MOD_SRC := src/third_party/mt19937.f90 src/third_party/kdtree2.f90 src/BDcode/colsort.f90 MOD_MOD := $(addprefix src/,$(notdir $(MOD_SRC:.f90=.mod))) -SRC := src/DATAcode/MINV.f90 src/DATAcode/find_struc.f90 src/BDcode/force_elas.f90 src/BDcode/force_ponp.f90 src/BDcode/RKstep.f90 src/BDcode/concalc.f90 src/SIMcode/debugging.f90 src/third_party/dgtsv.f src/BDcode/BDsim.f90 src/MCcode/MC_move.f90 src/MCcode/MCsim.f90 src/MCcode/MC_elas.f90 src/MCcode/MC_capsid_ex.f90 src/MCcode/MC_self.f90 src/SIMcode/globals.f90 src/SIMcode/stressp.f90 src/SIMcode/energy_ponp.f90 src/SIMcode/gasdev.f90 src/SIMcode/r_to_erg.f90 src/SIMcode/ran2.f90 src/SIMcode/decim.f90 src/SIMcode/wlcsim.f90 src/SIMcode/stress.f90 src/SIMcode/ran1.f90 src/SIMcode/energy_elas.f90 src/SIMcode/initcond.f90 src/SIMcode/getpara.f90 src/BDcode/colchecker.f90 +SRC := src/DATAcode/MINV.f90 src/DATAcode/find_struc.f90 src/BDcode/force_elas.f90 src/BDcode/force_ponp.f90 src/BDcode/RKstep.f90 src/BDcode/concalc.f90 src/SIMcode/debugging.f90 src/third_party/dgtsv.f src/BDcode/BDsim.f90 src/MCcode/MC_move.f90 src/MCcode/MCsim.f90 src/MCcode/MC_elas.f90 src/MCcode/MC_capsid_ex.f90 src/MCcode/MC_self.f90 src/SIMcode/globals.f90 src/SIMcode/stressp.f90 src/SIMcode/energy_ponp.f90 src/SIMcode/gasdev.f90 src/SIMcode/r_to_erg.f90 src/SIMcode/ran2.f90 src/SIMcode/decim.f90 src/SIMcode/wlcsim.f90 src/SIMcode/stress.f90 src/SIMcode/ran1.f90 src/SIMcode/energy_elas.f90 src/SIMcode/initcond.f90 src/SIMcode/getpara.f90 src/BDcode/colchecker.f90 src/BDcode/check_reactions.f90 src/BDcode/tot_rate_constant.f90 src/BDcode/methyl_profile.f90 src/SIMcode/initial_methyl_profile.f90 src/BDcode/calc_dist.f90 OBJ := $(addsuffix .o,$(basename $(MOD_SRC))) $(addsuffix .o,$(basename $(SRC))) TEST := src/CCcode/test_sort.f90 diff --git a/input/initial/r b/input/initial/r index f7e44c31..3791c6f4 100644 --- a/input/initial/r +++ b/input/initial/r @@ -1,11 +1,601 @@ - 22.359678313339863 25.173489826536443 10.724142839848524 - 22.363232033807471 25.222940195121392 10.722504528953939 - 22.366449871752952 25.272399756214032 10.720492246564241 - 22.368920377327925 25.321936445863205 10.719676816774223 - 22.371757365535547 25.371454543166045 10.718927495512480 - 22.370617431155718 25.420981947661257 10.716399908022931 - 22.360310756162477 25.469176329989434 10.722032483590242 - 22.329791876136255 25.503303362120111 10.741126869802795 - 22.302193357478291 25.532943404604143 10.769770221463688 - 22.298877888516969 25.552401136229594 10.815279080936268 - 22.296147779755731 25.553428319773484 10.864798201940769 +0.0 0.0 0.0 +27.2 0.0 0.0 +54.4 0.0 0.0 +81.6 0.0 0.0 +108.8 0.0 0.0 +136.0 0.0 0.0 +163.2 0.0 0.0 +190.4 0.0 0.0 +217.6 0.0 0.0 +244.8 0.0 0.0 +272.0 0.0 0.0 +299.2 0.0 0.0 +326.4 0.0 0.0 +353.6 0.0 0.0 +380.8 0.0 0.0 +408.0 0.0 0.0 +435.2 0.0 0.0 +462.4 0.0 0.0 +489.6 0.0 0.0 +516.8 0.0 0.0 +544.0 0.0 0.0 +571.2 0.0 0.0 +598.4 0.0 0.0 +625.6 0.0 0.0 +652.8 0.0 0.0 +680.0 0.0 0.0 +707.2 0.0 0.0 +734.4 0.0 0.0 +761.6 0.0 0.0 +788.8 0.0 0.0 +816.0 0.0 0.0 +843.2 0.0 0.0 +870.4 0.0 0.0 +897.6 0.0 0.0 +924.8 0.0 0.0 +952.0 0.0 0.0 +979.2 0.0 0.0 +1006.4 0.0 0.0 +1033.6 0.0 0.0 +1060.8 0.0 0.0 +1088.0 0.0 0.0 +1115.2 0.0 0.0 +1142.4 0.0 0.0 +1169.6 0.0 0.0 +1196.8 0.0 0.0 +1224.0 0.0 0.0 +1251.2 0.0 0.0 +1278.4 0.0 0.0 +1305.6 0.0 0.0 +1332.8 0.0 0.0 +1360.0 0.0 0.0 +1387.2 0.0 0.0 +1414.4 0.0 0.0 +1441.6 0.0 0.0 +1468.8 0.0 0.0 +1496.0 0.0 0.0 +1523.2 0.0 0.0 +1550.4 0.0 0.0 +1577.6 0.0 0.0 +1604.8 0.0 0.0 +1632.0 0.0 0.0 +1659.2 0.0 0.0 +1686.4 0.0 0.0 +1713.6 0.0 0.0 +1740.8 0.0 0.0 +1768.0 0.0 0.0 +1795.2 0.0 0.0 +1822.4 0.0 0.0 +1849.6 0.0 0.0 +1876.8 0.0 0.0 +1904.0 0.0 0.0 +1931.2 0.0 0.0 +1958.4 0.0 0.0 +1985.6 0.0 0.0 +2012.8 0.0 0.0 +2040.0 0.0 0.0 +2067.2 0.0 0.0 +2094.4 0.0 0.0 +2121.6 0.0 0.0 +2148.8 0.0 0.0 +2176.0 0.0 0.0 +2203.2 0.0 0.0 +2230.4 0.0 0.0 +2257.6 0.0 0.0 +2284.8 0.0 0.0 +2312.0 0.0 0.0 +2339.2 0.0 0.0 +2366.4 0.0 0.0 +2393.6 0.0 0.0 +2420.8 0.0 0.0 +2448.0 0.0 0.0 +2475.2 0.0 0.0 +2502.4 0.0 0.0 +2529.6 0.0 0.0 +2556.8 0.0 0.0 +2584.0 0.0 0.0 +2611.2 0.0 0.0 +2638.4 0.0 0.0 +2665.6 0.0 0.0 +2692.8 0.0 0.0 +2720.0 0.0 0.0 +2747.2 0.0 0.0 +2774.4 0.0 0.0 +2801.6 0.0 0.0 +2828.8 0.0 0.0 +2856.0 0.0 0.0 +2883.2 0.0 0.0 +2910.4 0.0 0.0 +2937.6 0.0 0.0 +2964.8 0.0 0.0 +2992.0 0.0 0.0 +3019.2 0.0 0.0 +3046.4 0.0 0.0 +3073.6 0.0 0.0 +3100.8 0.0 0.0 +3128.0 0.0 0.0 +3155.2 0.0 0.0 +3182.4 0.0 0.0 +3209.6 0.0 0.0 +3236.8 0.0 0.0 +3264.0 0.0 0.0 +3291.2 0.0 0.0 +3318.4 0.0 0.0 +3345.6 0.0 0.0 +3372.8 0.0 0.0 +3400.0 0.0 0.0 +3427.2 0.0 0.0 +3454.4 0.0 0.0 +3481.6 0.0 0.0 +3508.8 0.0 0.0 +3536.0 0.0 0.0 +3563.2 0.0 0.0 +3590.4 0.0 0.0 +3617.6 0.0 0.0 +3644.8 0.0 0.0 +3672.0 0.0 0.0 +3699.2 0.0 0.0 +3726.4 0.0 0.0 +3753.6 0.0 0.0 +3780.8 0.0 0.0 +3808.0 0.0 0.0 +3835.2 0.0 0.0 +3862.4 0.0 0.0 +3889.6 0.0 0.0 +3916.8 0.0 0.0 +3944.0 0.0 0.0 +3971.2 0.0 0.0 +3998.4 0.0 0.0 +4025.6 0.0 0.0 +4052.8 0.0 0.0 +4080.0 0.0 0.0 +4107.2 0.0 0.0 +4134.4 0.0 0.0 +4161.6 0.0 0.0 +4188.8 0.0 0.0 +4216.0 0.0 0.0 +4243.2 0.0 0.0 +4270.4 0.0 0.0 +4297.6 0.0 0.0 +4324.8 0.0 0.0 +4352.0 0.0 0.0 +4379.2 0.0 0.0 +4406.4 0.0 0.0 +4433.6 0.0 0.0 +4460.8 0.0 0.0 +4488.0 0.0 0.0 +4515.2 0.0 0.0 +4542.4 0.0 0.0 +4569.6 0.0 0.0 +4596.8 0.0 0.0 +4624.0 0.0 0.0 +4651.2 0.0 0.0 +4678.4 0.0 0.0 +4705.6 0.0 0.0 +4732.8 0.0 0.0 +4760.0 0.0 0.0 +4787.2 0.0 0.0 +4814.4 0.0 0.0 +4841.6 0.0 0.0 +4868.8 0.0 0.0 +4896.0 0.0 0.0 +4923.2 0.0 0.0 +4950.4 0.0 0.0 +4977.6 0.0 0.0 +5004.8 0.0 0.0 +5032.0 0.0 0.0 +5059.2 0.0 0.0 +5086.4 0.0 0.0 +5113.6 0.0 0.0 +5140.8 0.0 0.0 +5168.0 0.0 0.0 +5195.2 0.0 0.0 +5222.4 0.0 0.0 +5249.6 0.0 0.0 +5276.8 0.0 0.0 +5304.0 0.0 0.0 +5331.2 0.0 0.0 +5358.4 0.0 0.0 +5385.6 0.0 0.0 +5412.8 0.0 0.0 +5440.0 0.0 0.0 +5467.2 0.0 0.0 +5494.4 0.0 0.0 +5521.6 0.0 0.0 +5548.8 0.0 0.0 +5576.0 0.0 0.0 +5603.2 0.0 0.0 +5630.4 0.0 0.0 +5657.6 0.0 0.0 +5684.8 0.0 0.0 +5712.0 0.0 0.0 +5739.2 0.0 0.0 +5766.4 0.0 0.0 +5793.6 0.0 0.0 +5820.8 0.0 0.0 +5848.0 0.0 0.0 +5875.2 0.0 0.0 +5902.4 0.0 0.0 +5929.6 0.0 0.0 +5956.8 0.0 0.0 +5984.0 0.0 0.0 +6011.2 0.0 0.0 +6038.4 0.0 0.0 +6065.6 0.0 0.0 +6092.8 0.0 0.0 +6120.0 0.0 0.0 +6147.2 0.0 0.0 +6174.4 0.0 0.0 +6201.6 0.0 0.0 +6228.8 0.0 0.0 +6256.0 0.0 0.0 +6283.2 0.0 0.0 +6310.4 0.0 0.0 +6337.6 0.0 0.0 +6364.8 0.0 0.0 +6392.0 0.0 0.0 +6419.2 0.0 0.0 +6446.4 0.0 0.0 +6473.6 0.0 0.0 +6500.8 0.0 0.0 +6528.0 0.0 0.0 +6555.2 0.0 0.0 +6582.4 0.0 0.0 +6609.6 0.0 0.0 +6636.8 0.0 0.0 +6664.0 0.0 0.0 +6691.2 0.0 0.0 +6718.4 0.0 0.0 +6745.6 0.0 0.0 +6772.8 0.0 0.0 +6800.0 0.0 0.0 +6827.2 0.0 0.0 +6854.4 0.0 0.0 +6881.6 0.0 0.0 +6908.8 0.0 0.0 +6936.0 0.0 0.0 +6963.2 0.0 0.0 +6990.4 0.0 0.0 +7017.6 0.0 0.0 +7044.8 0.0 0.0 +7072.0 0.0 0.0 +7099.2 0.0 0.0 +7126.4 0.0 0.0 +7153.6 0.0 0.0 +7180.8 0.0 0.0 +7208.0 0.0 0.0 +7235.2 0.0 0.0 +7262.4 0.0 0.0 +7289.6 0.0 0.0 +7316.8 0.0 0.0 +7344.0 0.0 0.0 +7371.2 0.0 0.0 +7398.4 0.0 0.0 +7425.6 0.0 0.0 +7452.8 0.0 0.0 +7480.0 0.0 0.0 +7507.2 0.0 0.0 +7534.4 0.0 0.0 +7561.6 0.0 0.0 +7588.8 0.0 0.0 +7616.0 0.0 0.0 +7643.2 0.0 0.0 +7670.4 0.0 0.0 +7697.6 0.0 0.0 +7724.8 0.0 0.0 +7752.0 0.0 0.0 +7779.2 0.0 0.0 +7806.4 0.0 0.0 +7833.6 0.0 0.0 +7860.8 0.0 0.0 +7888.0 0.0 0.0 +7915.2 0.0 0.0 +7942.4 0.0 0.0 +7969.6 0.0 0.0 +7996.8 0.0 0.0 +8024.0 0.0 0.0 +8051.2 0.0 0.0 +8078.4 0.0 0.0 +8105.6 0.0 0.0 +8132.8 0.0 0.0 +8160.0 0.0 0.0 +8187.2 0.0 0.0 +8214.4 0.0 0.0 +8241.6 0.0 0.0 +8268.8 0.0 0.0 +8296.0 0.0 0.0 +8323.2 0.0 0.0 +8350.4 0.0 0.0 +8377.6 0.0 0.0 +8404.8 0.0 0.0 +8432.0 0.0 0.0 +8459.2 0.0 0.0 +8486.4 0.0 0.0 +8513.6 0.0 0.0 +8540.8 0.0 0.0 +8568.0 0.0 0.0 +8595.2 0.0 0.0 +8622.4 0.0 0.0 +8649.6 0.0 0.0 +8676.8 0.0 0.0 +8704.0 0.0 0.0 +8731.2 0.0 0.0 +8758.4 0.0 0.0 +8785.6 0.0 0.0 +8812.8 0.0 0.0 +8840.0 0.0 0.0 +8867.2 0.0 0.0 +8894.4 0.0 0.0 +8921.6 0.0 0.0 +8948.8 0.0 0.0 +8976.0 0.0 0.0 +9003.2 0.0 0.0 +9030.4 0.0 0.0 +9057.6 0.0 0.0 +9084.8 0.0 0.0 +9112.0 0.0 0.0 +9139.2 0.0 0.0 +9166.4 0.0 0.0 +9193.6 0.0 0.0 +9220.8 0.0 0.0 +9248.0 0.0 0.0 +9275.2 0.0 0.0 +9302.4 0.0 0.0 +9329.6 0.0 0.0 +9356.8 0.0 0.0 +9384.0 0.0 0.0 +9411.2 0.0 0.0 +9438.4 0.0 0.0 +9465.6 0.0 0.0 +9492.8 0.0 0.0 +9520.0 0.0 0.0 +9547.2 0.0 0.0 +9574.4 0.0 0.0 +9601.6 0.0 0.0 +9628.8 0.0 0.0 +9656.0 0.0 0.0 +9683.2 0.0 0.0 +9710.4 0.0 0.0 +9737.6 0.0 0.0 +9764.8 0.0 0.0 +9792.0 0.0 0.0 +9819.2 0.0 0.0 +9846.4 0.0 0.0 +9873.6 0.0 0.0 +9900.8 0.0 0.0 +9928.0 0.0 0.0 +9955.2 0.0 0.0 +9982.4 0.0 0.0 +10009.6 0.0 0.0 +10036.8 0.0 0.0 +10064.0 0.0 0.0 +10091.2 0.0 0.0 +10118.4 0.0 0.0 +10145.6 0.0 0.0 +10172.8 0.0 0.0 +10200.0 0.0 0.0 +10227.2 0.0 0.0 +10254.4 0.0 0.0 +10281.6 0.0 0.0 +10308.8 0.0 0.0 +10336.0 0.0 0.0 +10363.2 0.0 0.0 +10390.4 0.0 0.0 +10417.6 0.0 0.0 +10444.8 0.0 0.0 +10472.0 0.0 0.0 +10499.2 0.0 0.0 +10526.4 0.0 0.0 +10553.6 0.0 0.0 +10580.8 0.0 0.0 +10608.0 0.0 0.0 +10635.2 0.0 0.0 +10662.4 0.0 0.0 +10689.6 0.0 0.0 +10716.8 0.0 0.0 +10744.0 0.0 0.0 +10771.2 0.0 0.0 +10798.4 0.0 0.0 +10825.6 0.0 0.0 +10852.8 0.0 0.0 +10880.0 0.0 0.0 +10907.2 0.0 0.0 +10934.4 0.0 0.0 +10961.6 0.0 0.0 +10988.8 0.0 0.0 +11016.0 0.0 0.0 +11043.2 0.0 0.0 +11070.4 0.0 0.0 +11097.6 0.0 0.0 +11124.8 0.0 0.0 +11152.0 0.0 0.0 +11179.2 0.0 0.0 +11206.4 0.0 0.0 +11233.6 0.0 0.0 +11260.8 0.0 0.0 +11288.0 0.0 0.0 +11315.2 0.0 0.0 +11342.4 0.0 0.0 +11369.6 0.0 0.0 +11396.8 0.0 0.0 +11424.0 0.0 0.0 +11451.2 0.0 0.0 +11478.4 0.0 0.0 +11505.6 0.0 0.0 +11532.8 0.0 0.0 +11560.0 0.0 0.0 +11587.2 0.0 0.0 +11614.4 0.0 0.0 +11641.6 0.0 0.0 +11668.8 0.0 0.0 +11696.0 0.0 0.0 +11723.2 0.0 0.0 +11750.4 0.0 0.0 +11777.6 0.0 0.0 +11804.8 0.0 0.0 +11832.0 0.0 0.0 +11859.2 0.0 0.0 +11886.4 0.0 0.0 +11913.6 0.0 0.0 +11940.8 0.0 0.0 +11968.0 0.0 0.0 +11995.2 0.0 0.0 +12022.4 0.0 0.0 +12049.6 0.0 0.0 +12076.8 0.0 0.0 +12104.0 0.0 0.0 +12131.2 0.0 0.0 +12158.4 0.0 0.0 +12185.6 0.0 0.0 +12212.8 0.0 0.0 +12240.0 0.0 0.0 +12267.2 0.0 0.0 +12294.4 0.0 0.0 +12321.6 0.0 0.0 +12348.8 0.0 0.0 +12376.0 0.0 0.0 +12403.2 0.0 0.0 +12430.4 0.0 0.0 +12457.6 0.0 0.0 +12484.8 0.0 0.0 +12512.0 0.0 0.0 +12539.2 0.0 0.0 +12566.4 0.0 0.0 +12593.6 0.0 0.0 +12620.8 0.0 0.0 +12648.0 0.0 0.0 +12675.2 0.0 0.0 +12702.4 0.0 0.0 +12729.6 0.0 0.0 +12756.8 0.0 0.0 +12784.0 0.0 0.0 +12811.2 0.0 0.0 +12838.4 0.0 0.0 +12865.6 0.0 0.0 +12892.8 0.0 0.0 +12920.0 0.0 0.0 +12947.2 0.0 0.0 +12974.4 0.0 0.0 +13001.6 0.0 0.0 +13028.8 0.0 0.0 +13056.0 0.0 0.0 +13083.2 0.0 0.0 +13110.4 0.0 0.0 +13137.6 0.0 0.0 +13164.8 0.0 0.0 +13192.0 0.0 0.0 +13219.2 0.0 0.0 +13246.4 0.0 0.0 +13273.6 0.0 0.0 +13300.8 0.0 0.0 +13328.0 0.0 0.0 +13355.2 0.0 0.0 +13382.4 0.0 0.0 +13409.6 0.0 0.0 +13436.8 0.0 0.0 +13464.0 0.0 0.0 +13491.2 0.0 0.0 +13518.4 0.0 0.0 +13545.6 0.0 0.0 +13572.8 0.0 0.0 +13600.0 0.0 0.0 +13627.2 0.0 0.0 +13654.4 0.0 0.0 +13681.6 0.0 0.0 +13708.8 0.0 0.0 +13736.0 0.0 0.0 +13763.2 0.0 0.0 +13790.4 0.0 0.0 +13817.6 0.0 0.0 +13844.8 0.0 0.0 +13872.0 0.0 0.0 +13899.2 0.0 0.0 +13926.4 0.0 0.0 +13953.6 0.0 0.0 +13980.8 0.0 0.0 +14008.0 0.0 0.0 +14035.2 0.0 0.0 +14062.4 0.0 0.0 +14089.6 0.0 0.0 +14116.8 0.0 0.0 +14144.0 0.0 0.0 +14171.2 0.0 0.0 +14198.4 0.0 0.0 +14225.6 0.0 0.0 +14252.8 0.0 0.0 +14280.0 0.0 0.0 +14307.2 0.0 0.0 +14334.4 0.0 0.0 +14361.6 0.0 0.0 +14388.8 0.0 0.0 +14416.0 0.0 0.0 +14443.2 0.0 0.0 +14470.4 0.0 0.0 +14497.6 0.0 0.0 +14524.8 0.0 0.0 +14552.0 0.0 0.0 +14579.2 0.0 0.0 +14606.4 0.0 0.0 +14633.6 0.0 0.0 +14660.8 0.0 0.0 +14688.0 0.0 0.0 +14715.2 0.0 0.0 +14742.4 0.0 0.0 +14769.6 0.0 0.0 +14796.8 0.0 0.0 +14824.0 0.0 0.0 +14851.2 0.0 0.0 +14878.4 0.0 0.0 +14905.6 0.0 0.0 +14932.8 0.0 0.0 +14960.0 0.0 0.0 +14987.2 0.0 0.0 +15014.4 0.0 0.0 +15041.6 0.0 0.0 +15068.8 0.0 0.0 +15096.0 0.0 0.0 +15123.2 0.0 0.0 +15150.4 0.0 0.0 +15177.6 0.0 0.0 +15204.8 0.0 0.0 +15232.0 0.0 0.0 +15259.2 0.0 0.0 +15286.4 0.0 0.0 +15313.6 0.0 0.0 +15340.8 0.0 0.0 +15368.0 0.0 0.0 +15395.2 0.0 0.0 +15422.4 0.0 0.0 +15449.6 0.0 0.0 +15476.8 0.0 0.0 +15504.0 0.0 0.0 +15531.2 0.0 0.0 +15558.4 0.0 0.0 +15585.6 0.0 0.0 +15612.8 0.0 0.0 +15640.0 0.0 0.0 +15667.2 0.0 0.0 +15694.4 0.0 0.0 +15721.6 0.0 0.0 +15748.8 0.0 0.0 +15776.0 0.0 0.0 +15803.2 0.0 0.0 +15830.4 0.0 0.0 +15857.6 0.0 0.0 +15884.8 0.0 0.0 +15912.0 0.0 0.0 +15939.2 0.0 0.0 +15966.4 0.0 0.0 +15993.6 0.0 0.0 +16020.8 0.0 0.0 +16048.0 0.0 0.0 +16075.2 0.0 0.0 +16102.4 0.0 0.0 +16129.6 0.0 0.0 +16156.8 0.0 0.0 +16184.0 0.0 0.0 +16211.2 0.0 0.0 +16238.4 0.0 0.0 +16265.6 0.0 0.0 +16292.8 0.0 0.0 +16320.0 0.0 0.0 diff --git a/input/initial/u b/input/initial/u index 24b2b8e2..6c33eef0 100644 --- a/input/initial/u +++ b/input/initial/u @@ -1,11 +1,601 @@ - 0.10923594096898130 0.99040355009642678 -8.4665914965910610E-002 - 4.4617454951404761E-002 0.99739025541674453 -5.6762321247280256E-002 - 6.1398658881095233E-002 0.99739502084830978 -3.7859966648171345E-002 - 8.5417652162559921E-002 0.99618420089167292 1.7912637797238656E-002 - -2.1837455674946687E-002 0.99820311855387034 -5.5800175976171755E-002 - -0.21685488396982769 0.97135109576090140 9.7216295252024895E-002 - -0.63049916033795306 0.70269064074281828 0.32969178367921392 - -0.57833197627749688 0.65761039460621462 0.48278431428622687 - -0.17742802753327525 0.44212312038759488 0.87923059629677880 - -5.1845897104629092E-002 -3.9925824519026321E-002 0.99785666881065305 - -6.9817355337446818E-002 3.7370442700420281E-002 0.99685956227848915 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 +1.0 0.0 0.0 diff --git a/input/initial_methyl_profile.f90 b/input/initial_methyl_profile.f90 new file mode 100644 index 00000000..ef93072a --- /dev/null +++ b/input/initial_methyl_profile.f90 @@ -0,0 +1,31 @@ +subroutine methyl_profile(nt) + implicit none + integer :: ind + integer, intent(in) :: nt + integer, intent(out) :: meth_status(nt) + ! set initial methylation profile + + ! current version: place one nucleation site in the center of the chain + do ind = 1,nt/2 + meth_status(ind) = 0 + end do + meth_status((nt/2)+1) = 1 + do ind = (nt/2)+2,nt + meth_status(ind) = 0 + end do + + + + + + + + + + + + + + + + diff --git a/input/input b/input/input index a591014a..f1e0fa02 100644 --- a/input/input +++ b/input/input @@ -3,11 +3,11 @@ !-Record 1 ! LP Persistence length ! of DNA in nm - 1.0 + 53.0 !-Record 2 ! L Chain length - 1000.0 + 16320.0 !-Record 3 ! LBOX Box edge length - for MC box sizes @@ -23,7 +23,7 @@ !-Record 6 ! N Number of beads - 101 + 601 !-Record 7 Sarah was running 1000 ! NP Number of polymers - won't interact unless interaction code added @@ -31,11 +31,11 @@ !-Record 8 Sarah: 5x10e4 time takes for 10pers length chains on average ! TF Total simulation time - 10 + 10000 !-Record 9 ! INDMAX Total number of save points - 100 + 10000 !-Record 10 ! DT Timestep for integration - Sarah used 0.2 in above @@ -43,7 +43,7 @@ !-Record 11 ! FRMFILE Load in the inital conf? - otherwise from MC - 0 + 1 !-Record 12 ! BROWN Include Brownian forces? @@ -59,18 +59,30 @@ !-Record 15 Quinn: 1000s times #polymers, there's a script to check if OK ! NINIT Number initialization MC steps - 40beads@rigid@2000poly==4e6 - 1000 + 0 !-Record 16 ! NSTEP Number MC steps per save 0 !-Record 17 + ! DYN Include dynamics? + 1 + + !-Record 18 ! FPT_DIST l1 distance triggering a "collision" between beads - 2 + 35/53 - !-Record 18 Algorithm for collision detection: 0) NONE 1) brute force, + !-Record 19 Algorithm for collision detection: 0) NONE 1) brute force, ! COL_TYPE 2) k-d tree, 3) Bruno's O(n) v1, 1 + !-Record 20 + ! KM Rate of methylation + 10.0 + + !-Record 21 + ! KD Rate of demethylation + 0.0 + ! ---------------------------------------------------- diff --git a/run-parallel.sh b/run-parallel.sh new file mode 100755 index 00000000..e11220ab --- /dev/null +++ b/run-parallel.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +set -eu +set -o pipefail + +codedir=`pwd` + +COUNTER=0 +until [ ! -d par-run-dir.$COUNTER ]; do + let COUNTER+=1 +done +pardir="par-run-dir.$COUNTER" +echo "Running simulations in ${COUNTER}!" +nprocs=`grep -c ^processor /proc/cpuinfo` +let nprocs-=1 +echo "Using $nprocs processors!" +mkdir -p "$pardir" +cd "$pardir" +for core in `seq 1 $nprocs`; do + rundir=run.$core + mkdir -p "$rundir" + cp -r "${codedir}/input" "${codedir}/run_parameter.pl" "$rundir" + cd "$rundir" + mkdir -p data savedata + echo "#!/bin/bash" >> runsim.sh + echo "rm data/*" >> runsim.sh + echo "../../wlcsim" >> runsim.sh + chmod a+x runsim.sh + ./run_parameter.pl & + cd .. +done + diff --git a/run_parameter.pl b/run_parameter.pl new file mode 100755 index 00000000..45c9be15 --- /dev/null +++ b/run_parameter.pl @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +#use strict; +#require 'calcVecs.pl'; + +my $npara=41; # Number of simulations +my $paraind=4; # Index of parameter to vary +my $val1=0.0; # First value of parameter +my $val2=1.0; # Second value of parameter +my $logspace=0; # Are parameter values log spaced? +my $intval=0; # Is the parameter an integer? + +my $ii=1; +my $val; + +system("cp input/input input/input-save"); + +while ($ii <= $npara) { + +# Evaluate the value (either linear or log spaced) + if ($logspace == 1) { + $val=$val1*exp(($ii-1)/($npara-1)*log($val2/$val1)); + } else { + $val=$val1+($ii-1)/($npara-1)*($val2-$val1); + } + +# Reset value to an integer (if $intval==1) + + if ($intval == 1) { + $val=int($val+$val/abs($val*2)); + } + +# Alter the value in the input file + + my $filein="input/input-save"; + my $fileout="input/input"; + open my $in, '<', $filein or die "Can't read old file: $!"; + open my $out, '>', $fileout or die "Can't write new file: $!"; + + while( <$in> ) # print the lines before the change + { + print $out $_; + last if $. == 2+4*$paraind-1; # line number before change + } + + my $line = <$in>; + $line = " $val\n"; + print $out $line; + + while( <$in> ) # print the rest of the lines + { + print $out $_; + } + + close $in; + close $out; + +# Run simulation and move data to savedata directory in numbered folder + + unless(-e "savedata" or mkdir "savedata") { die "Unable to stat savedata dir"; } + system("./runsim.sh"); + system("cp -r data savedata/data$ii"); + system("cp input/input savedata/data$ii/input$ii"); + + $ii++; +} diff --git a/run_parameter_series.pl b/run_parameter_series.pl new file mode 100755 index 00000000..2f30be73 --- /dev/null +++ b/run_parameter_series.pl @@ -0,0 +1,78 @@ +#!/usr/bin/perl -w + +#use strict; +#require 'calcVecs.pl'; + +my $npara=20; # Number of simulations +my $paraind=6; # Index of parameter to vary +my $val1=5; # First value of parameter +my $val2=500; # Second value of parameter +my $logspace=1; # Are parameter values log spaced? +my $intval=1; # Is the parameter an integer? +my $nsim=50; # Total number of duplicates + +my $ii; +my $val; +my $itot; + +system("cp input/input input/input-save"); + +$itot=1; +while ($itot <= $nsim) { + $ii=1; + while ($ii <= $npara) { + +# Evaluate the value (either linear or log spaced) + if ($logspace == 1) { + $val=$val1*exp(($ii-1)/($npara-1)*log($val2/$val1)); + } else { + $val=$val1+($ii-1)/($npara-1)*($val2-$val1); + } + +# Reset value to an integer (if $intval==1) + + if ($intval == 1) { + $val=int($val+$val/abs($val*2)); + } + +# Alter the value in the input file + + my $filein="input/input-save"; + my $fileout="input/input"; + open my $in, '<', $filein or die "Can't read old file: $!"; + open my $out, '>', $fileout or die "Can't write new file: $!"; + + while( <$in> ) # print the lines before the change + { + print $out $_; + last if $. == 2+4*$paraind-1; # line number before change + } + + my $line = <$in>; + $line = " $val\n"; + print $out $line; + + while( <$in> ) # print the rest of the lines + { + print $out $_; + } + + close $in; + close $out; + +# Run simulation and move data to savedata directory in numbered folder + + unless(-e "savedata" or mkdir "savedata") { die "Unable to stat savedata dir"; } + system("./runsim.sh"); + if ($itot == 1) { + system("mkdir savedata/data$ii"); + } + system("cp data/out1 savedata/data$ii/out1-$itot"); + system("cp data/out2 savedata/data$ii/out2-$itot"); + system("cp data/out3 savedata/data$ii/out3-$itot"); + system("cp input/input savedata/data$ii/input$ii"); + + $ii++; + } + $itot++; +} diff --git a/runsim.sh b/runsim.sh new file mode 100755 index 00000000..980b5e47 --- /dev/null +++ b/runsim.sh @@ -0,0 +1,5 @@ +#!/bin/bash +set -o pipefail +set -eu + +make run diff --git a/src/BDcode/BDsim.f90 b/src/BDcode/BDsim.f90 index dd4db90c..739ff47e 100644 --- a/src/BDcode/BDsim.f90 +++ b/src/BDcode/BDsim.f90 @@ -2,7 +2,9 @@ SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & INTON,IDUM,PARA,SIMTYPE,HAS_COLLIDED,FPT_DIST, & - COL_TYPE) + COL_TYPE,METH_STATUS,IN_RXN_RAD,PAIRS,KM,KD,KTOT, & + NUC_SITE,NUM_SPREAD,NUM_METHYLATED,NUM_DECAY, & + COULD_REACT,RXN_HAPPEN,DT_MOD,DYN) ! ! External subroutine to perform a Brownian dynamics simulation. @@ -20,7 +22,7 @@ SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & ! Variables in the simulation - DOUBLE PRECISION B(NT-1) ! Bond length + DOUBLE PRECISION B(NT,1) ! Bond length DOUBLE PRECISION RS(NT,3) ! R during the step DOUBLE PRECISION US(NT,3) ! R during the step DOUBLE PRECISION L0 ! Bond distances @@ -72,6 +74,23 @@ SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & DOUBLE PRECISION FPT_DIST ! l1 dist to trigger collision INTEGER COL_TYPE ! algorithm to use for collision detection +! Variables for methyl profile tracking + INTEGER METH_STATUS(NT) ! methylation status of each site: 1 = methylated, 0 = unmethylated + INTEGER IN_RXN_RAD(NT,NT) ! is pair of sites within reaction radius? 1 = yes, 0 = no + INTEGER PAIRS(2,NT) ! array that holds indices of sites that could react + DOUBLE PRECISION KM ! rate of methylation + DOUBLE PRECISION KD ! rate of demethylation + DOUBLE PRECISION KTOT ! total rate constant + INTEGER NUC_SITE ! bead index of nucleation site + INTEGER NUM_SPREAD ! total number of spreading events + INTEGER NUM_METHYLATED ! number of methylated sites + INTEGER NUM_DECAY ! total number of decay events + INTEGER COULD_REACT ! number of pairs in which methyl mark could spread + INTEGER RXN_HAPPEN ! reaction status: 1 = reaction, 0 = no reaction + DOUBLE PRECISION DT_MOD ! time remaining in timestep for Gillespie algorithm + INTEGER DYN ! include dynamics? + + ! Load the input parameters EB=PARA(1) @@ -123,13 +142,31 @@ SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & 20 CONTINUE 10 CONTINUE + ! Begin the time integration DO WHILE (TIME.LT.TTOT) - call CHECK_COLLISIONS(R, NT, HAS_COLLIDED, FPT_DIST, TIME, COL_TYPE) + call CHECK_COLLISIONS(R, NT, HAS_COLLIDED, FPT_DIST, TIME, COL_TYPE, IN_RXN_RAD) + + DT_MOD = DT + + DO WHILE (RXN_HAPPEN.EQ.1) + + COULD_REACT = 0 + + call CHECK_REACTIONS(R, NT, METH_STATUS, IN_RXN_RAD, COULD_REACT, FPT_DIST, PAIRS) + + call TOT_RATE_CONSTANT(NT, COULD_REACT, METH_STATUS, KM, KD, KTOT, NUM_METHYLATED) + + call METHYL_PROFILE(NT,METH_STATUS,KTOT,KM,KD,NUM_METHYLATED,TIME, & + RXN_HAPPEN,PAIRS,DT,DT_MOD,NUC_SITE,NUM_SPREAD,NUM_DECAY) + + END DO + RXN_HAPPEN = 1 + if (DYN.EQ.1) then ! Calculate the random forces and torques for use in this ! timestep calculation if BROWN=1 @@ -246,6 +283,7 @@ SUBROUTINE BDsim(R,U,NT,N,NP,TIME,TTOT,DT,BROWN, & RK=RK+1 ENDDO + endif TIME=TIME+DT diff --git a/src/BDcode/calc_dist.f90 b/src/BDcode/calc_dist.f90 new file mode 100644 index 00000000..b0fd5c9b --- /dev/null +++ b/src/BDcode/calc_dist.f90 @@ -0,0 +1,20 @@ +subroutine calc_dist(r,nt,fpt_dist,in_rxn_rad,k1,k2) + implicit none + integer :: i + double precision :: d, distance + integer, intent(in) :: nt, in_rxn_rad(nt,nt), k1 + double precision, intent(in) :: r(nt,3), fpt_dist + integer,intent(out) :: k2 + ! when more than 2 beads are within reaction distance, find the 2 that are closest together + distance = fpt_dist + do i = 1, nt + if ((in_rxn_rad(k1,i).eq.1) .and. (k1.ne.i)) then + d = sqrt(((r(k1,1)-r(i,1))**2)+((r(k1,2)-r(i,2))**2)+((r(k1,3)-r(i,3))**2)) + if (d.lt.distance) then + distance = d + k2 = i + end if + end if + end do +end + diff --git a/src/BDcode/check_reactions.f90 b/src/BDcode/check_reactions.f90 new file mode 100644 index 00000000..9bf46a56 --- /dev/null +++ b/src/BDcode/check_reactions.f90 @@ -0,0 +1,42 @@ +subroutine check_reactions(r, nt, meth_status, in_rxn_rad, could_react, fpt_dist, pairs) + implicit none + integer, intent(in) :: meth_status(nt) + double precision, intent(inout) :: r(nt,3), fpt_dist + double precision :: check_pair(nt,nt) + integer, intent(inout) :: could_react, nt, in_rxn_rad(nt,nt), pairs(2,nt) + integer :: k1,k2 + + ! initialize variables + do k1 = 1, nt + do k2 = 1, nt + check_pair(k1,k2) = 0 + end do + end do + + do k1 = 1, nt + pairs(1,k1) = 0 + pairs(2,k1) = 0 + end do + + ! for pairs of beads that are close enough to react, check that one + ! is methylated and one unmethylated + do k1 = 1, nt - 1 + do k2 = k1 + 1, nt + if ((in_rxn_rad(k1,k2).eq.1).and.(check_pair(k1,k2).eq.0)) then + check_pair(k1,k2) = 1 + check_pair(k2,k1) = 1 + if (meth_status(k1).eq.1 .and. meth_status(k2).eq.0) then + could_react = could_react + 1 + pairs(1,could_react) = k1 + pairs(2,could_react) = k2 + else if (meth_status(k1).eq.0 .and. meth_status(k2).eq.1) then + could_react = could_react + 1 + pairs(1,could_react) = k2 + pairs(2,could_react) = k1 + end if + end if + end do + end do +end + + diff --git a/src/BDcode/colchecker.f90 b/src/BDcode/colchecker.f90 index 7764a121..8b5c4bcc 100644 --- a/src/BDcode/colchecker.f90 +++ b/src/BDcode/colchecker.f90 @@ -14,37 +14,59 @@ subroutine insertion_sort(n,a) 30 continue end -subroutine check_collisions(r, nt, has_collided, fpt_dist, time, col_type) +subroutine check_collisions(r, nt, has_collided, fpt_dist, time, col_type, in_rxn_rad) implicit none integer, intent(in) :: nt, col_type double precision, intent(in) :: fpt_dist, time double precision, intent(in) :: r(nt,3) double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) + if (col_type.eq.0) then return else if (col_type.eq.1) then - call check_collisions_brute(r, nt, has_collided, fpt_dist, time) + call check_collisions_brute(r, nt, has_collided, fpt_dist, time, in_rxn_rad) else if (col_type.eq.2) then call check_collisions_kd(r, nt, has_collided, fpt_dist, time) else if (col_type.eq.3) then - call check_collisions_bb(r, nt, has_collided, fpt_dist, time) - end if + call check_collisions_bb(r, nt, has_collided, fpt_dist, time, in_rxn_rad) + end if end subroutine check_collisions_brute(r, nt, has_collided, fpt_dist, & - time) - integer nt - double precision fpt_dist, time - double precision r(nt,3), has_collided(nt, nt) + time, in_rxn_rad) + implicit none + + integer, intent(in) :: nt + integer k1, k2 + double precision, intent(in) :: fpt_dist, time, r(nt,3) + double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) + + + !integer nt, in_rxn_rad(nt,nt),k1,k2 + !double precision fpt_dist, time + !double precision r(nt,3), has_collided(nt, nt) + + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + ! check if the particles have collided do k1 = 1, nt do k2 = 1, nt - if (has_collided(k1,k2).lt.0.0d0 .and. k1.ne.k2 & - .and. abs(r(k1,1) - r(k2,1)) < fpt_dist & - .and. abs(r(k1,2) - r(k2,2)) < fpt_dist & - .and. abs(r(k1,3) - r(k2,3)) < fpt_dist) then - has_collided(k1,k2) = time - end if + if ((k1.ne.k2) & + .and. (abs(r(k1,1) - r(k2,1)) < fpt_dist) & + .and. (abs(r(k1,2) - r(k2,2)) < fpt_dist) & + .and. (abs(r(k1,3) - r(k2,3)) < fpt_dist)) then + in_rxn_rad(k1,k2) = 1 + if (has_collided(k1,k2).lt.0.0d0) then + has_collided(k1,k2) = time + end if + end if end do end do end @@ -52,13 +74,20 @@ subroutine check_collisions_brute(r, nt, has_collided, fpt_dist, & subroutine check_collisions_kd(r, nt, has_collided, fpt_dist, time) use kdtree2_module, only : kdtree2, kdtree2_result, kdtree2_create, & kdtree2_r_nearest_around_point - - integer nt, nfound, nalloc, k1, k2, i + implicit none + integer nt, nfound, nalloc, k1, k2, i, in_rxn_rad(nt,nt) double precision fpt_dist, time double precision r(nt,3), has_collided(nt, nt) type(kdtree2), pointer :: col_tree type(kdtree2_result), allocatable :: kd_results(:) + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + col_tree => kdtree2_create(r, rearrange = .true., sort = .false.) do k1 = 1,nt call kdtree2_r_nearest_around_point(col_tree, idxin = k1, & @@ -66,6 +95,7 @@ subroutine check_collisions_kd(r, nt, has_collided, fpt_dist, time) results = kd_results) do i = 1,nfound k2 = kd_results(i)%idx + in_rxn_rad(k1,k2) = 1 if (has_collided(k1,k2) .lt. 0) then has_collided(k1,k2) = time endif @@ -73,7 +103,7 @@ subroutine check_collisions_kd(r, nt, has_collided, fpt_dist, time) enddo end -subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time) +subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time, in_rxn_rad) ! at each time point, we want to have 2 "pointer arrays", ind & indi ! r(ind(:,k),k) is in order for k in 1,2,3 i.e. [~,ind(:,1)] = sort(r(:,1) ! ind(indi(i,k),k) == i for k in 1,2,3 @@ -87,6 +117,7 @@ subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time) integer, intent(in) :: nt double precision, intent(in) :: fpt_dist, time, r(nt,3) double precision, intent(inout) :: has_collided(nt, nt) + integer, intent(inout) :: in_rxn_rad(nt,nt) integer :: neighbors(nt,nt) ! most of array won't be used, probably ! neighbors(1:num_neighbors(i),i) holds neighbors of bead i for each i @@ -107,8 +138,16 @@ subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time) ! better: "" "" if d == 1 (i.e. we're adding j to triplet array) integer, save, allocatable, dimension(:,:) :: ind, indi integer, save :: is_allocated = 0 ! "static" variable, allow initial setup - integer :: curr_indi, curr_ind, i, j, d, rd0 + integer :: curr_indi, curr_ind, i, j, d, rd0, k1, k2 double precision :: rneighbor + + ! initialize in_rxn_rad + do k1 = 1, nt + do k2 = 1, nt + in_rxn_rad(k1,k2) = 0 + end do + end do + ! initialize ind and indi on first pass, requires O(n log n) sort if (is_allocated == 0) then is_allocated = 1 @@ -218,6 +257,7 @@ subroutine check_collisions_bb(r, nt, has_collided, fpt_dist, time) ! neighbors(neighborj, beadi), num_neighbors(beadi) do i = 1, nt do j = 1, num_neighbors(i) + in_rxn_rad(i,neighbors(j,i)) = 1 if (has_collided(neighbors(j,i),i) < 0.0_dp) then has_collided(neighbors(j,i),i) = time endif diff --git a/src/BDcode/methyl_profile.f90 b/src/BDcode/methyl_profile.f90 new file mode 100644 index 00000000..a18759ee --- /dev/null +++ b/src/BDcode/methyl_profile.f90 @@ -0,0 +1,63 @@ +subroutine methyl_profile(nt,meth_status,ktot,km,kd,num_methylated,time,rxn_happen,pairs,dt,dt_mod,nuc_site,num_spread,num_decay) + use mt19937, only : grnd + implicit none + integer, intent(in) :: nt, pairs(2,nt), nuc_site + integer, intent(inout) :: meth_status(nt), rxn_happen, num_spread, num_methylated, num_decay + double precision, intent(in) :: km, kd, ktot, dt, time + double precision, intent(inout) :: dt_mod + double precision :: time_rxn, rn1, rn2, rn3, prob_no_rxn, prob_demeth, prob_meth + integer :: site_rxn, count, i + + ! for pairs of beads that could transfer a methyl mark, + ! perform Gillespie algorithm to determine if reaction happens and then update methyl profile + + if (rxn_happen.eq.1) then + ! does a reaction occur? + rn1 = grnd() + prob_no_rxn = exp(-ktot*dt_mod) + if (rn1.gt.prob_no_rxn) then + ! which reaction occurred? + rn2 = grnd() + prob_demeth = (kd/ktot)*(num_methylated-1) + if (rn2.lt.prob_demeth) then ! one site is demethylated + site_rxn = ceiling(rn2/(kd/ktot)) + count = 0 + i = 1 + do while ((count.lt.site_rxn).and.(i.lt.nuc_site)) + count = count + meth_status(i) + i = i+1 + end do + if ((count.eq.site_rxn).and.((i-1).lt.nuc_site)) then + meth_status(i-1) = 0 + num_decay = num_decay + 1 + elseif ((count.lt.site_rxn).and.(i.eq.nuc_site)) then + i = i+1 + do while (count.lt.site_rxn) + count = count + meth_status(i) + i = i+1 + end do + meth_status(i-1) = 0 + num_decay = num_decay + 1 + end if + else ! one site is methylated + prob_meth = rn2 - prob_demeth + site_rxn = ceiling(prob_meth/(km/ktot)) + meth_status(pairs(2,site_rxn)) = 1 + num_spread = num_spread + 1 + end if + ! at what time did it occur? + rn3 = grnd() + time_rxn = time - (1/ktot)*log(rn2*(prob_no_rxn-1)+1) + dt_mod = time + dt - time_rxn + else + rxn_happen = 0 + end if + end if + + num_methylated = sum(meth_status) + +end + + + + diff --git a/src/BDcode/tot_rate_constant.f90 b/src/BDcode/tot_rate_constant.f90 new file mode 100644 index 00000000..9a1fb597 --- /dev/null +++ b/src/BDcode/tot_rate_constant.f90 @@ -0,0 +1,15 @@ +subroutine tot_rate_constant(nt,could_react,meth_status,km,kd,ktot,num_methylated) + implicit none + integer, intent(in) :: nt, could_react, meth_status(nt) + double precision, intent(in) :: km, kd + double precision, intent(inout) :: ktot + integer, intent(inout) :: num_methylated + + ! determine total rate constant for all possible reactions + ktot = (num_methylated-1)*kd + could_react*km +end + + + + + diff --git a/src/SIMcode/initcond.f90 b/src/SIMcode/initcond.f90 index 29baaa1d..ab1cf67c 100644 --- a/src/SIMcode/initcond.f90 +++ b/src/SIMcode/initcond.f90 @@ -51,7 +51,9 @@ SUBROUTINE initcond(R,U,NT,N,NP,IDUM,FRMFILE,PARA) ! Setup the choice parameters - INPUT=1 + ! use input = 0 for initial conformation to be straight chain + !INPUT=1 + INPUT=0 ! Seed the random number generator off the computer clock diff --git a/src/SIMcode/initial_methyl_profile.f90 b/src/SIMcode/initial_methyl_profile.f90 new file mode 100644 index 00000000..70a35f06 --- /dev/null +++ b/src/SIMcode/initial_methyl_profile.f90 @@ -0,0 +1,23 @@ +subroutine initial_methyl_profile(nt,meth_status,nuc_site) + implicit none + integer, intent(in) :: nt + integer, intent(inout) :: meth_status(nt), nuc_site + integer :: i + + nuc_site = ceiling(real(nt/2.0)) + + do i = 1, nuc_site - 1 + meth_status(i) = 0 + end do + + meth_status(nuc_site) = 1 + + do i = nuc_site + 1, nt + meth_status(i) = 0 + end do + +end + + + + diff --git a/src/SIMcode/wlcsim.f90 b/src/SIMcode/wlcsim.f90 index 2459a328..399382f2 100644 --- a/src/SIMcode/wlcsim.f90 +++ b/src/SIMcode/wlcsim.f90 @@ -36,7 +36,7 @@ PROGRAM wlcsim INTEGER INDMAX ! Maximum index in series INTEGER IND ! Ind in series INTEGER TENS ! Decimal of index - character*4 fileind ! Index of output + character*5 fileind ! Index of output character*16 snapnm ! File for output ! Simulation input variables @@ -47,6 +47,7 @@ PROGRAM wlcsim INTEGER LOGTIME ! Is data recorded in log time? DOUBLE PRECISION DT0 ! Initial time step size INTEGER NSTEP,NINIT + INTEGER DYN ! Include dynamics ! Monte Carlo variables @@ -85,6 +86,20 @@ PROGRAM wlcsim DOUBLE PRECISION FPT_DIST ! l1 dist to trigger collision INTEGER COL_TYPE ! what kind of collision checking to use +! Variables for tracking methylation profile + INTEGER, ALLOCATABLE, DIMENSION(:):: METH_STATUS ! methylation status of each site: 1 = methylated, 0 = unmethylated + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IN_RXN_RAD ! is pair of sites within reaction radius? 1 = yes, 0 = no + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: PAIRS ! array that holds indices of sites that could react + DOUBLE PRECISION KM ! rate of methylation + DOUBLE PRECISION KD ! rate of demethylation + DOUBLE PRECISION KTOT ! total rate constant + INTEGER NUC_SITE ! bead index of nucleation site + INTEGER NUM_SPREAD ! total number of spreading events + INTEGER NUM_METHYLATED ! number of methylated sites + INTEGER NUM_DECAY ! total number of decay events + INTEGER COULD_REACT ! number of pairs in which methyl mark could spread + INTEGER RXN_HAPPEN ! reaction status: 1 = reaction, 0 = no reaction + DOUBLE PRECISION DT_MOD ! time remaining in timestep for Gillespie algorithm ! Load in the parameters for the simulation @@ -112,9 +127,15 @@ PROGRAM wlcsim read (unit=5, fmt='(2(/))') read (unit=5, fmt=*) NSTEP read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) DYN + read (unit=5, fmt='(2(/))') read (unit=5, fmt=*) FPT_DIST read (unit=5, fmt='(2(/))') read (unit=5, fmt=*) COL_TYPE + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) KM + read (unit=5, fmt='(2(/))') + read (unit=5, fmt=*) KD close(5) call getpara(PARA,DT,SIMTYPE) DT0=DT @@ -134,11 +155,32 @@ PROGRAM wlcsim ALLOCATE(HAS_COLLIDED(1,1)) HAS_COLLIDED = -1.0d+0 endif + ALLOCATE(METH_STATUS(NT)) + ALLOCATE(IN_RXN_RAD(NT,NT)) + ALLOCATE(PAIRS(2,NT)) + + NUM_SPREAD = 0 + NUM_DECAY = 0 ! Setup the initial condition call initcond(R,U,NT,N,NP,IDUM,FRMFILE,PARA) + call initial_methyl_profile(NT,METH_STATUS,NUC_SITE) + + OPEN (UNIT = 1, FILE = 'data/m0', STATUS = 'NEW') + DO I=1,NT + WRITE(1,*) meth_status(I) + ENDDO + CLOSE(1) + + KTOT = 1.0 + NUM_METHYLATED = sum(meth_status) + RXN_HAPPEN = 1 + + PRINT *, 'initial number of methylated sites =', NUM_METHYLATED + + ! Turn on moves for each simulation type if (SIMTYPE.EQ.1) then @@ -188,8 +230,10 @@ PROGRAM wlcsim ! Perform an initialization MC simulation - call MCsim(R,U,NT,N,NP,NINIT,BROWN,INTON,IDUM,PARA,MCAMP, & - SUCCESS,MOVEON,WINDOW,SIMTYPE) + if (NINIT.NE.0) then + call MCsim(R,U,NT,N,NP,NINIT,BROWN,INTON,IDUM,PARA,MCAMP, & + SUCCESS,MOVEON,WINDOW,SIMTYPE) + endif ! Save the conformation and PSI angles @@ -242,7 +286,7 @@ PROGRAM wlcsim call MCsim(R,U,NT,N,NP,NSTEP,BROWN,INTON,IDUM,PARA,MCAMP, & SUCCESS,MOVEON,WINDOW,SIMTYPE) -! Perform a Brownian dynamics simulation over time step +! Perform a Brownian dynamics simulation over time step, only if DYN.EQ.1 if (LOGTIME.EQ.0) then TSAVE = TF*IND/INDMAX @@ -251,14 +295,17 @@ PROGRAM wlcsim endif if (NSTEP.EQ.0) then call BDsim(R,U,NT,N,NP,TIME,TSAVE,DT,BROWN,INTON,IDUM, & - PARA,SIMTYPE,HAS_COLLIDED,FPT_DIST,COL_TYPE) + PARA,SIMTYPE,HAS_COLLIDED,FPT_DIST, COL_TYPE, & + METH_STATUS,IN_RXN_RAD,PAIRS,KM,KD,KTOT, & + NUC_SITE,NUM_SPREAD,NUM_METHYLATED,NUM_DECAY, & + COULD_REACT,RXN_HAPPEN,DT_MOD,DYN) endif ! Save the conformation and the metrics - TENS=nint(log10(1.*IND)-0.4999)+1 - write (fileind,'(I4)'), IND - snapnm= 'data/r'//fileind((4-TENS+1):4) + TENS=nint(log10(1.*IND)-0.49999)+1 + write (fileind,'(I5)'), IND + snapnm= 'data/r'//fileind((5-TENS+1):5) OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') IB=1 DO 50 I=1,NP @@ -269,7 +316,7 @@ PROGRAM wlcsim 50 CONTINUE CLOSE(1) - snapnm= 'data/u'//fileind((4-TENS+1):4) + snapnm= 'data/u'//fileind((5-TENS+1):5) OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') IB=1 DO 70 I=1,NP @@ -283,12 +330,39 @@ PROGRAM wlcsim snapnm='data/coltimes' IF (COL_TYPE.NE.0) then OPEN (UNIT=1, FILE=snapnm, STATUS='REPLACE') - DO, I=1,NT + DO I=1,NT WRITE(1,*) ( HAS_COLLIDED(i,j), j=1,NT ) ENDDO CLOSE(1) ENDIF + snapnm='data/m'//fileind((5-TENS+1):5) + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') + DO I=1,NT + WRITE(1,*) METH_STATUS(I) + ENDDO + CLOSE(1) + + snapnm='data/p'//fileind((5-TENS+1):5) + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'NEW') + WRITE(1,*) COULD_REACT + CLOSE(1) + + snapnm='data/num_spread' + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'REPLACE') + WRITE(1,*) NUM_SPREAD + CLOSE(1) + + snapnm='data/num_decay' + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'REPLACE') + WRITE(1,*) NUM_DECAY + CLOSE(1) + + snapnm='data/num_meth' + OPEN (UNIT = 1, FILE = snapnm, STATUS = 'REPLACE') + WRITE(1,*) NUM_METHYLATED + CLOSE(1) + call stress(SIG,R,U,NT,N,NP,PARA,INTON,SIMTYPE) call stressp(COR,R,U,R0,U0,NT,N,NP,PARA,INTON,SIMTYPE) @@ -315,6 +389,9 @@ PROGRAM wlcsim print*, 'End-to-end distance poly 1 ', & sqrt((R(N,1)-R(1,1))**2.+(R(N,2)-R(1,2))**2.+(R(N,3)-R(1,3))**2.) PRINT*, 'Simulation type ', SIMTYPE + PRINT*, 'Number of spreading events ', NUM_SPREAD + PRINT*, 'Number of methylated sites ', NUM_METHYLATED + PRINT*, 'Number of decay events ', NUM_DECAY IND=IND+1 diff --git a/wlcsim.dep b/wlcsim.dep index 91ce5851..0063b3f2 100644 --- a/wlcsim.dep +++ b/wlcsim.dep @@ -2,10 +2,14 @@ src/third_party/mt19937.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/third_party/mt19937.f90 -o src/third_party/mt19937.o +src/SIMcode/initial_methyl_profile.o : + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/initial_methyl_profile.f90 -o src/SIMcode/initial_methyl_profile.o src/DATAcode/find_struc.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/DATAcode/find_struc.f90 -o src/DATAcode/find_struc.o src/SIMcode/energy_ponp.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/energy_ponp.f90 -o src/SIMcode/energy_ponp.o +src/BDcode/tot_rate_constant.o : + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/BDcode/tot_rate_constant.f90 -o src/BDcode/tot_rate_constant.o src/SIMcode/ran1.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/ran1.f90 -o src/SIMcode/ran1.o src/SIMcode/stressp.o : @@ -31,6 +35,8 @@ src/SIMcode/getpara.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/getpara.f90 -o src/SIMcode/getpara.o src/SIMcode/globals.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/globals.f90 -o src/SIMcode/globals.o +src/BDcode/check_reactions.o : + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/BDcode/check_reactions.f90 -o src/BDcode/check_reactions.o src/SIMcode/decim.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/decim.f90 -o src/SIMcode/decim.o src/BDcode/colchecker.o : \ @@ -46,6 +52,10 @@ src/SIMcode/initcond.o : \ gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/initcond.f90 -o src/SIMcode/initcond.o src/BDcode/colsort.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/BDcode/colsort.f90 -o src/BDcode/colsort.o +src/third_party/kdtree2.o : \ + src/third_party/kdtree2.o \ + src/third_party/kdtree2.o + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/third_party/kdtree2.f90 -o src/third_party/kdtree2.o src/SIMcode/wlcsim.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/wlcsim.f90 -o src/SIMcode/wlcsim.o src/BDcode/force_elas.o : @@ -60,10 +70,11 @@ src/DATAcode/MINV.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/DATAcode/MINV.f90 -o src/DATAcode/MINV.o src/SIMcode/stress.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/SIMcode/stress.f90 -o src/SIMcode/stress.o -src/third_party/kdtree2.o : \ - src/third_party/kdtree2.o \ - src/third_party/kdtree2.o - gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/third_party/kdtree2.f90 -o src/third_party/kdtree2.o +src/BDcode/calc_dist.o : + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/BDcode/calc_dist.f90 -o src/BDcode/calc_dist.o +src/BDcode/methyl_profile.o : \ + src/third_party/mt19937.o + gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/BDcode/methyl_profile.f90 -o src/BDcode/methyl_profile.o src/MCcode/MC_self.o : gfortran -c -ggdb -Jsrc -Isrc -Isrc/third_party -cpp src/MCcode/MC_self.f90 -o src/MCcode/MC_self.o src/SIMcode/energy_elas.o : diff --git a/wlcsim.exe b/wlcsim.exe index 57f35fc2..4e27e4cd 100755 Binary files a/wlcsim.exe and b/wlcsim.exe differ