# Kevin R. Geurts
# February 13, 2022

# This program simulates a network model using the method of Biller and
# Petruccione, J. Chem. Phys., 89(1), pp.577-582, 1988.  Motion is affine
# but for the prefactor 1-(Q/Qo)^n.  The FENE force law is used.  The
# loss rate is (1/Lambdao)(1)/(1-(Q/Qo)^n*m).
# Any strand exceeding the nondimensional length of one is reset to a
# nondimensional length of .99.

# Elongational flow is simulated.

# Compiler Directives: (From FORTRAN)
#	  (provide access to random numbers and to date and time functions)
# $NOSTANDARD SYSTEM, HP9000_800 INTRINSICS
#    Compiler Command:
#		  f77 program.f -o program 
#		  +O3 seems okay, +OP causes different results
#
#     Nondimensionalization Scheme:
#             stress tensor is divided by NokT
#             strand coordinates are divided by Qo
#             strand number density is divided by initial number density No
#             Kappa and GammaDot are multiplied by the loss rate constant
#             loss rate is multiplied by the loss rate constant
#             time rates of change of internal coordinates are multiplied by the loss rate constant and divided by Qo
#             time step size is divided by the loss rate constant
#             y is divided by the loss rate constant
#
#     Variable Definitions:
#             q(max,4)       Internal coordinates of each strand in the network (Cartesian).  The 4th column stores the squared magnitude of the strand's end-to-end vector.
#             strands         Number of strands in the network at any given time step
#             eps              Time step size
#             qamdot         Imposed elongation rate
#             lossprob       Probability that a strand will be lost from the network in a given time step
#             lossrate        Strand loss rate
#             seed            Random number generator seed
#             p1,p2           Random numbers generated by ran0
#             exist             Is a given strand still in the network?
#             repack          Need to repack q?
#             y                  t-y equal segment creation time
#             begstrand      Number of strands in initial equilibrium ensemble
#             steps           Total time steps simulated
#             pi(4,keeps)     XX,YY,ZZ,YX components of total stress tensor stored at various times
#             eqq(max,4)      Internal coordinates of the original equilibrium ensemble for use in strand creation. The 4th column stores the squared magnitude of the end-to-end vector of each strand.
#             eqlr(max)       Loss rate for each equilibrium strand
#             eqlp(max)       Loss probability for each equilibrium strand	
#             max             Maximum number of strands in the network
#             keeps           Number of times to store away <qq>
#             e(4)            Sum of qq's used to find error bars
#             ee(4)           Sum of (qq)^2's used to find error bars
#             errbar(4,keeps) Error bars on <qq>'s
#             outfil          Name of output file
#             banner          String to place at top of output file
#             today             String with the date in it
#             timestr         String with the time in it
#             qdotq           Squared magnitude of a strands's end-to-end vector
#             alpha           Modified Affine Prefactor
#             nstr(keeps)     Number of strands in ensemble at a given time
#             titl1           First line of a plot title
#             titl2           Second line of a plot title
#             symbol(ncur)    Symbols for a plot
#             xp(keeps,1)   X points for a plot
#             yp(keeps,1)   Y points for a plot
#             xp2(slices,1)   X points for another plot
#             yp2(slices,1)   Y points for another plot
#             n               Exponent in prefactor expression
#             qdist(slices)   Distribution of strand lengths at end of run
#             slices          Number of divisions between 0 and Qo in qdist 
#             qave            Average value of Q at end of run
#             ub,lb           Upper and lower bounds for 'slicing' up Q-dist
#             indist          Strands of length between 0 and Qo in final ensemble at end of run
#             qdex            Factor by which to extend computation of Q-dist beyond Qo
#             dover           Fraction of total time steps to figure Q-dist over
#             dsteps          Time steps to figure Q-dist over
#             dstr            Strands averaged over for <Q>		
#             pie             This should be extremely obvious
#             b               The FENE Parameter (HQo^2/kT)
#             jeq             Normalization constant for equilibriium FENE Dumbbell distribution function DPL2 Eq. (L) of Table 11.5-1
#             r               -
#             theta         - Internal coordinates of a dumbbell in spherical coordinates used to find equilibrium distribution
#             phi            -    
#             mm              mm*n is exponent on (Q/Qo) in the loss rate
#
#      program net

#     integer max,keeps,slices
#	real dover

max=100000
keeps=50
slices=100
dover=0.2

      real q(max,4),eps,gamdot,lossprob,lossrate,p1,p2,y,pi(4,keeps)
      real eqq(max,4),ee(4),e(4),errbar(4,keeps),qdotq,alpha
      real nstr(keeps),yp(keeps,1),xp(keeps,1),n,qdist(slices)
	real qave,ub,lb,xp2(slices,1),yp2(slices,1)
	real r,theta,phi,b,jeq,eqlp(max),eqlr(max),pie,mm

      integer strands,begstrand,steps,indist,dsteps,dstr

      logical exist(max),repack

      character*9 today
      character*8 timestr
      character*30 outfil
      character*70 banner
      character*60 titl1,titl2
      character*1 symbol(1)

c     -----  get input from user

	write(*,*)'--------------------------------------------------'
	write(*,*)'-----  LEW/KRG FENE Network Model Simulator  -----'
	write(*,*)'-----  (decreasingly affine strand motion)   -----'
	write(*,*)'--------------------------------------------------'
      write(*,*)' '
      write(*,*)' '
      write(*,*)'elongation rate. . .'
      read(*,*) gamdot
      write(*,*) '# strands in equilibrium ensemble. . .'
      write(*,*) 'no more than ',max
      read(*,*) begstrand
      write(*,*)'time step size. . .'
      read(*,*) eps
      write(*,*)'total time steps. . .'
      read(*,*) steps
	write(*,*)'Q-Dist extension factor. . .'
	read(*,*) qdex
	write(*,*) 'FENE Parameter. . .'
	read(*,*) b
	write(*,*) 'Exponent in Prefactor. . .'
	read(*,*) n
	write(*,*) 'Loss rate exponent is m*n.  Enter m. . .'
 	read(*,*) mm
      write(*,*)'Name of output file . . .'
      read(*,*) outfil
      write(*,*)'Idenifier for output. . .'
      read(*,*) banner

      open(unit=1,file=outfil,status='unknown')
      call date(today)
      call time(timestr)
      strands=begstrand
	call srand(1)
	dsteps=nint(steps*dover)
      symbol(1)='*'
	pie=acos(-1.0)

c     -----  zero out the storage of pi

      do i=1,keeps
        do j=1,4
          pi(j,i)=0.0
        end do
      end do

c	-----  zero out storage of final Q-distribution and <Q> storage

	dstr=0
	indist=0
	qave=0.0
	do i=1,slices
	  qdist(i)=0.0
	end do

c     -----  generate an equilibrium ensemble of strands less than max
c	-----  utilizing a rejection technique

	jeq=(1./(2.*pie*beta(3./2.,(b+2.)/2.)))
	do i=1,begstrand
	  p1=1.0
	  p2=0.0
	  do while (p1.gt.p2)
	    r=rand()
	    theta=pie*rand()
	    phi=2.*pie*rand()
	    p1=rand()
	    p2=jeq*((1.-r*r)**(b/2.))*r*r*sin(theta)
	  end do
	  eqq(i,1)=r*sin(theta)*cos(phi)
	  eqq(i,2)=r*sin(theta)*sin(phi)
	  eqq(i,3)=r*cos(theta)
        eqq(i,4)=eqq(i,1)*eqq(i,1)+eqq(i,2)*eqq(i,2)+eqq(i,3)*eqq(i,3)
	  if (eqq(i,4).gt.1.0) pause 'Eq. Strand Too Long'
	  eqlr(i)=1./(1-(sqrt(eqq(i,4)))**(mm*n))
        eqlp(i)=1.-exp(-1.*eqlr(i)*eps)
      end do

c	-----  Set initial network ensemble to equilibriium ensemble.

	do i=1,begstrand
	  q(i,1)=eqq(i,1)
	  q(i,2)=eqq(i,2)
	  q(i,3)=eqq(i,3)
	  q(i,4)=eqq(i,4)
	  exist(i)=.true.
	end do
	repack=.false.

c     -----  Beginning of main loop over each time step

      do 100 l=1,steps

c     -----  Advance each strand over one time step

      do i=1,strands

c	-----  Dependence of Alpha on Strand Length

	  alpha=1.-(sqrt(q(i,4)))**n

c	-----  Actual movement of the strand by Euler integration

	  q(i,1)=q(i,1)-alpha*gamdot*.5*q(i,1)*eps
	  q(i,2)=q(i,2)-alpha*gamdot*.5*q(i,2)*eps
	  q(i,3)=q(i,3)+alpha*gamdot*q(i,3)*eps
	  q(i,4)=q(i,1)*q(i,1)+q(i,2)*q(i,2)+q(i,3)*q(i,3)  
 	  if (q(i,4).gt.1.0) then
    	    q(i,4)=.99*q(i,4)
	    q(i,3)=sign(sqrt(q(i,4)-q(i,2)*q(i,2)-q(i,1)*q(i,1))
     &		     ,q(i,3))
 	  end if
	end do
	
c	-----  Check survival of each strand

	do i=1,strands
	  lossrate=1./(1-(sqrt(q(i,4)))**(mm*n))
	  lossprob=1.-exp(-1.*lossrate*eps)
	  p1=rand()
	  if (p1.le.lossprob) then
	    exist(i)=.false.
	    strands=strands-1
	    repack=.true.
	  end if
 	end do

c     -----  Repack q if necessary

      if (repack) then
        i=1
        j=1
        do while (j.le.strands)
          do while (.not.exist(i))
            i=i+1
          end do
          q(j,1)=q(i,1)
          q(j,2)=q(i,2)
          q(j,3)=q(i,3)
          q(j,4)=q(i,4)
          exist(j)=.true.
          i=i+1
          j=j+1
        end do
      end if
      repack=.false.

c     -----  Create new strands to enter the network

      do i=1,begstrand
        p1=rand()
        if (p1.le.eqlp(i).and.strands.lt.max) then
          strands=strands+1
          exist(strands)=.true.
          p1=rand()
          y=-log(1.-p1*eqlp(i))/eqlr(i)
          q(strands,1)=eqq(i,1)
          q(strands,2)=eqq(i,2)
          q(strands,3)=eqq(i,3)
	    q(strands,4)=eqq(i,4)

c	-----  Find alpha for the current strand and time step

	    alpha=1.-(sqrt(q(strands,4)))**n

c	-----  Actual movement of the strand by Euler integration

 	    q(strands,1)=q(strands,1)-alpha*gamdot*.5*q(strands,1)*y
 	    q(strands,2)=q(strands,2)-alpha*gamdot*.5*q(strands,2)*y
 	    q(strands,3)=q(strands,3)+alpha*gamdot*q(strands,3)*y
	    q(strands,4)=q(strands,1)*q(strands,1)+q(strands,2)*
     &                 q(strands,2)+q(strands,3)*q(strands,3)
	    if (q(strands,4).gt.1.0) then
	      write(*,*) gamdot,q(strands,4)
	      pause 'New Moving Strand Too Long'
	    end if
        end if
      end do

c     -----  Find Stress If Needed

      if (mod(l,(steps/keeps)).eq.0) then
          nstr(l*keeps/steps)=float(strands)/begstrand
        do k=1,4
          e(k)=0.0
          ee(k)=0.0
        end do
        do i=1,strands
          pi(1,(l*keeps/steps))=pi(1,(l*keeps/steps))
     &	    +b*q(i,1)*q(i,1)/(1-q(i,4))
          pi(2,(l*keeps/steps))=pi(2,(l*keeps/steps))
     &	    +b*q(i,2)*q(i,2)/(1-q(i,4))
          pi(3,(l*keeps/steps))=pi(3,(l*keeps/steps))
     &	    +b*q(i,3)*q(i,3)/(1-q(i,4))
          pi(4,(l*keeps/steps))=pi(4,(l*keeps/steps))
     &	    +b*q(i,1)*q(i,2)/(1-q(i,4))
          e(1)=e(1)+b*q(i,1)*q(i,1)/(1-q(i,4))
          e(2)=e(2)+b*q(i,2)*q(i,2)/(1-q(i,4))
          e(3)=e(3)+b*q(i,3)*q(i,3)/(1-q(i,4))
          e(4)=e(4)+b*q(i,1)*q(i,2)/(1-q(i,4))
          ee(1)=ee(1)+b*b*q(i,1)*q(i,1)*q(i,1)*q(i,1)
     &	    /(1-q(i,4))/(1-q(i,4))
          ee(2)=ee(2)+b*b*q(i,2)*q(i,2)*q(i,2)*q(i,2)
     &	    /(1-q(i,4))/(1-q(i,4))
          ee(3)=ee(3)+b*b*q(i,3)*q(i,3)*q(i,3)*q(i,3)
     &	    /(1-q(i,4))/(1-q(i,4))
          ee(4)=ee(4)+b*b*q(i,1)*q(i,2)*q(i,1)*q(i,2)
     &	    /(1-q(i,4))/(1-q(i,4))
        end do
        do k=1,4
          e(k)=e(k)/strands
          ee(k)=ee(k)/strands
          errbar(k,(l*keeps/steps))=sqrt((ee(k)-e(k)*e(k))/strands)
        end do
      end if

c	-----  Generation of distribution of Q and <Q>

	if (l.gt.(steps-dsteps)) then
	  dstr=dstr+strands
	  do i=1,strands
	    qdotq=sqrt(q(i,4))
	    qave=qave+qdotq
	    do j=0,slices-1
	      lb=(1.0)*qdex*j/slices
	      ub=(1.0)*qdex*(j+1)/slices
	      if ((lb.le.qdotq).and.(ub.gt.qdotq)) then
		  qdist(j+1)=qdist(j+1)+1.
		  indist=indist+1
	      end if
	    end do
	  end do
	end if

c     -----  Time to take another time step

100   continue

c     -----  Output the results to a data file

      write(1,*)'-------------------------------------------------'
      write(1,*)'-----  Quasi-Lodge Network Model Simulator  -----'
      write(1,*)'-------------------------------------------------'
      write(1,*) ' '
      write(1,*) ' '
      write(1,*) banner
      write(1,*) ' '
      write(1,*) 'Date:  ',today,'     Time:  ',timestr
      write(1,*) 'Elongation Rate:  ',gamdot
      write(1,*) 'Starting Strands:  ',begstrand
      write(1,*) 'Time Step Size:  ',eps
      write(1,*) 'Total Time Steps:  ',steps
      write(1,*) 'FENE parameter:  ',b
      write(1,*) 'Exponent in Alpha:  ',n
	write(1,*) 'Q-Dist. Extension Factor:  ',qdex
	write(1,*) 'Loss Exponent Factor:  ',mm
      write(1,*) ' '
      write(1,*) ' '
      write(1,*) '             time     Off Dag Pi   Trou',
     &          'ton     Trouton     segments'
      write(1,*) '          ----------  ----------  -----',
     &          '-----  ----------  ----------'
      do i=1,keeps
        write(1,1) (float(i)/keeps)*steps*eps,
     &             pi(4,i)/begstrand,
     &             (pi(3,i)-pi(1,i))/(begstrand*gamdot),
     &             (pi(2,i)-pi(1,i))/(begstrand*gamdot),
     &             nstr(i)
1       format(10x,f10.6,2x,f10.6,2x,f10.6,2x,f10.6,2x,f10.6)
      end do
      write(1,*) ' '
      write(1,*) ' '
      write(1,*) '             time      Err Off     Err ',
     &          'Trout   Err Trout'
      write(1,*) '          ----------  ----------  -----',
     &          '-----  ----------  ----------'
      do i=1,keeps
        write(1,1) (float(i)/keeps)*steps*eps,
     &             errbar(4,i),
     &             (errbar(3,i)+errbar(1,i))/gamdot,
     &             (errbar(2,i)+errbar(1,i))/gamdot
      end do
      write(1,*) ' '
      write(1,*) ' '
	write(1,*) '            (Q/Qo)    Distribut.'
	write(1,*) '          ----------  ----------'
	do j=1,slices
	  write(1,1) (j-.5)*qdex/slices,
     &	  qdist(j)*slices/indist/qdex
	end do
	write(1,*) ' '
	write(1,*) '     <Q>:           ',qave/dstr
	write(1,*)'     Long Strands:  ',floatj(dstr-indist)/dsteps
	write(1,*) ' '
	write(1,*) ' '

c	-----  Write a block of data to read into plotting program  -----

      do i=1,keeps
        write(1,5) (float(i)/keeps)*steps*eps,
     &             pi(4,i)/begstrand,
     &             (pi(3,i)-pi(1,i))/(begstrand*gamdot),
     &             (pi(2,i)-pi(1,i))/(begstrand*gamdot),
     &             nstr(i),
     &             errbar(4,i),
     &             (errbar(3,i)+errbar(1,i))/gamdot,
     &             (errbar(2,i)+errbar(1,i))/gamdot
5       format(f10.6,2x,f10.6,2x,f10.6,2x,f10.6,2x,f10.6,2x,f10.6,
     &         f10.6,2x,f10.6)
      end do
	write(1,*) ' '
	write(1,*) ' '

c     -----  Make some plots

      titl1='Off Diagonal Stress vs Time'
      titl2=' '
      do i=1,keeps
        xp(i,1)=(float(i)/keeps)*steps*eps
        yp(i,1)=pi(4,i)/begstrand
      end do
      call qplot(1,keeps,xp,yp,symbol,titl1,titl2)
      write(1,*) ' '
      write(1,*) ' '

      titl1='Trouton Viscosity vs Time'
      titl2=' '
      do i=1,keeps
        xp(i,1)=(float(i)/keeps)*steps*eps
        yp(i,1)=(pi(3,i)-pi(1,i))/(begstrand*gamdot)
      end do
      call qplot(1,keeps,xp,yp,symbol,titl1,titl2)
      write(1,*) ' '
      write(1,*) ' '

      titl1='Trouton Viscosity vs Time'
      titl2=' '
      do i=1,keeps
        xp(i,1)=(float(i)/keeps)*steps*eps
        yp(i,1)=(pi(2,i)-pi(1,i))/(begstrand*gamdot)
      end do
      call qplot(1,keeps,xp,yp,symbol,titl1,titl2)
      write(1,*) ' '
      write(1,*) ' '

      titl1='Segment Number Density vs Time'
      titl2=' '
      do i=1,keeps
        xp(i,1)=(float(i)/keeps)*steps*eps
        yp(i,1)=nstr(i)
      end do
      call qplot(1,keeps,xp,yp,symbol,titl1,titl2)
      write(1,*) ' '
      write(1,*) ' '

      titl1='Final Q-Distribution'
      titl2=' '
      do i=1,slices
        xp2(i,1)=(i-.5)*qdex/slices
        yp2(i,1)=qdist(i)*slices/indist/qdex
      end do
      call qplot(1,slices,xp2,yp2,symbol,titl1,titl2)

      close(1)

      end

c       -----  Plotting subroutine

        subroutine qplot(ncur,npts,x,y,symbol,titl1,titl2)

        parameter (cpl=60,lpp=20)

        real x,xmax,xmin,y,ymax,ymin
        real xtick1,xtick2,xtick3,xtick4,xtick5,ytick

        integer i,j,m,n,npts,ncur

        character*60 titl1,titl2
        character*1 symbol,line(0:cpl,0:lpp)

        dimension x(npts,ncur), y(npts,ncur), symbol(ncur)

C       -----  top and bottom axes  -----

        do 100 i=1,cpl-1
          line(i,0)='-'
          line(i,lpp)='-'
100     continue

C       -----  x tick marks -----

        line(cpl/2,0)='|'
        line(cpl/2,lpp)='|'
        line(cpl/4,0)='|'
        line(cpl/4,lpp)='|'
        line(3*cpl/4,0)='|'
        line(3*cpl/4,lpp)='|'

C       -----  left and right axes  -----

        do 110 i=0,lpp
          line(0,i)='|'
          line(cpl,i)='|'
110     continue

C       -----  blank out middle of graph -----

        do 120 i=1,cpl-1
          do 130 j=1,lpp-1
            line(i,j)=' '
130       continue
120     continue

C       -----  y tick marks  -----

        line(0,lpp/4)='+'
        line(cpl,lpp/4)='+'
        line(0,lpp/2)='+'
        line(cpl,lpp/2)='+'
        line(0,3*lpp/4)='+'
        line(cpl,3*lpp/4)='+'

C       -----  find maximums and minimums  -----

        xmax=x(1,1)
        xmin=x(1,1)
        ymax=y(1,1)
        ymin=y(1,1)
        do 137 n=1,ncur
          do 135 m=1,npts
            if(x(m,n).gt.xmax) xmax=x(m,n)
            if(x(m,n).lt.xmin) xmin=x(m,n)
            if(y(m,n).gt.ymax) ymax=y(m,n)
            if(y(m,n).lt.ymin) ymin=y(m,n)
135      continue
137     continue

C       -----  fill in the points  -----

        do 145 n=1,ncur
          do 140 m=1,npts
            j=nint((lpp-2)*(y(m,n)-ymin)/(ymax-ymin))+1
            i=nint((cpl-2)*(x(m,n)-xmin)/(xmax-xmin))+1
            line(i,j)=symbol(n)
140       continue
145     continue

C       -----  print the titles  -----

        write(1,*) titl1
        write(1,*) titl2
        write(1,*) ' '

C       -----  print the top-axis tick labels  -----

        xtick1=xmin+.25*(xmax-xmin)
        xtick2=xmin+.75*(xmax-xmin)
        write(1,5) xtick1,xtick2
5       format(10x,f10.5,20x,f10.5)

C       -----  print most of the graph  -----

        do 200 m=lpp,0,-1
          if(m.eq.lpp.or.m.eq.lpp*3/4.or.m.eq.lpp/2.or.
     &      m.eq.lpp/4.or.m.eq.0) then
            ytick=ymin+(m*(ymax-ymin)/lpp)
            write(1,3) (line(n,m), n=0,cpl), ytick
3           format(61a1,1x,f9.5)
          else
            write(1,2) (line(n,m), n=0,cpl)
2          format(61a1)
          end if
200     continue

C       -----  print the bottom-axis tick labels  -----

        xtick3=xmin
        xtick4=xmin+.5*(xmax-xmin)
        xtick5=xmax
        write(1,4) xtick3,xtick4,xtick5
4       format(f10.5,15x,f10.5,15x,f10.5)

        return
        end

c
c	-----  BETA Function  -----
c
	function beta(z,w)
c
	beta=exp(gammln(z)+gammln(w)-gammln(z+w))
c
	return
	end

c
c	-----  ln of the Gamma Function  -----
c
      FUNCTION GAMMLN(XX)
      REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER
      DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0,
     *    -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/
      DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/
      X=XX-ONE
      TMP=X+FPF
      TMP=(X+HALF)*LOG(TMP)-TMP
      SER=ONE
      DO 11 J=1,6
        X=X+ONE
        SER=SER+COF(J)/X
11    CONTINUE
      GAMMLN=TMP+LOG(STP*SER)
      RETURN
      END
