--- /dev/null
+ subroutine distfit(debug,maxit)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DISTFIT'
+ DIMENSION X(MAXRES),DIAGH(MAXRES),phiold(maxres)
+ logical debug,sing
+
+cinput------------------------------------
+c NX=NRES-3
+c NY=((NRES-4)*(NRES-5))/2
+cinput------------------------------------
+ctest MAXIT=20
+ TOL=0.5
+ MAXMAR=10
+ RL=100.0
+
+ CALL TRANSFER(NRES,phi,phiold)
+
+ F0=RDIF()
+
+cd WRITE (IOUT,*) 'DISTFIT: F0=',F0
+
+
+ DO IT=1,MAXIT
+ CALL RDERIV
+ CALL HEVAL
+
+ DO I=1,NX
+ DIAGH(I)=H(I,I)
+ ENDDO
+ RL=RL*0.1
+
+ DO IMAR=1,MAXMAR
+ DO I=1,NX
+ H(I,I)=DIAGH(I)+RL
+ ENDDO
+ CALL TRANSFER(NX,XX,X)
+ CALL BANACH(NX,MAXRES,H,X,sing)
+ AIN=0.0
+ DO I=1,NX
+ AIN=AIN+DABS(X(I))
+ ENDDO
+ IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN
+ if (debug) then
+ WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED'
+ WRITE (IOUT,*) 'IT=',it,'F=',F0
+ endif
+ RETURN
+ ENDIF
+ DO I=4,NRES
+ phi(I)=phiold(I)+mask(i)*X(I-3)
+c print *,X(I-3)
+ ENDDO
+
+ F1=RDIF()
+cd WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1
+ IF (F1.LT.F0) THEN
+ CALL TRANSFER(NRES,phi,phiold)
+ F0=F1
+ GOTO 1
+ ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN
+ if (debug) then
+ WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT'
+ WRITE (IOUT,*) 'IT=',it,'F=',F1
+ endif
+ RETURN
+ ENDIF
+ RL=RL*10.0
+ ENDDO
+ WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED'
+ WRITE (IOUT,*) 'IT=',it,'F=',F0
+ CALL TRANSFER(NRES,phiold,phi)
+ RETURN
+ 1 continue
+cd write (iout,*) "it",it," imar",imar," f0",f0
+ enddo
+ WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit
+ return
+ END
+
+ double precision FUNCTION RDIF()
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DISTFIT'
+
+c print *,'in rdif'
+
+ suma=0.0
+ ind=0
+ call chainbuild
+ do i=1,nres-3
+ do j=i+3,nres
+ ind=ind+1
+ if (w(ind).ne.0.0) then
+ DIJ=DIST(i,j)
+ suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind))
+ DD(ind)=DIJ
+c print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma
+ endif
+ enddo
+ enddo
+
+ RDIF=suma
+ RETURN
+ END
+
+ SUBROUTINE RDERIV
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.GEO'
+ DIMENSION E12(3),R13(3),R24(3),PRODU(3)
+
+ DO I=1,NY
+ DO J=1,NX
+ DRDG(I,J)=0.0
+ ENDDO
+ ENDDO
+ DO I=1,NX
+ I1=I+1
+ I2=I+2
+ CALL VEC(I1,I2,E12)
+ DO J=1,I
+ DO K=1,3
+ R13(K)=C(K,J)-C(K,I1)
+ ENDDO
+ DO K=I2+1,NRES
+ DO L=1,3
+ R24(L)=C(L,K)-C(L,I2)
+ ENDDO
+ IND=((J-1)*(2*NRES-J-6))/2+K-3
+ PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2)
+ PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3)
+ PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1)
+ DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K)
+ ENDDO
+ ENDDO
+ ENDDO
+ RETURN
+ END
+
+ SUBROUTINE HEVAL
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DISTFIT'
+
+ DO I=1,NX
+ XI=0.0
+ HII=0.0
+ DO K=1,NY
+ BKI=DRDG(K,I)
+ BKIWK=w(K)*BKI
+ XI=XI+BKIWK*(D0(K)-DD(K))
+ HII=HII+BKI*BKIWK
+ ENDDO
+ H(I,I)=HII
+ XX(I)=XI
+ DO J=I+1,NX
+ HIJ=0.0
+ DO K=1,NY
+ HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K)
+ ENDDO
+ H(I,J)=HIJ
+ H(J,I)=HIJ
+ ENDDO
+ ENDDO
+ RETURN
+ END
+
+
+ SUBROUTINE VEC(I,J,U)
+*
+* Find the unit vector from atom (I) to atom (J). Store in U.
+*
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ DIMENSION U(3)
+
+ ANORM=0.0
+ DO K=1,3
+ UK=C(K,J)-C(K,I)
+ ANORM=ANORM+UK*UK
+ U(K)=UK
+ ENDDO
+ ANORM=SQRT(ANORM)
+ DO K=1,3
+ U(K)=U(K)/ANORM
+ ENDDO
+ RETURN
+ END
+
+ SUBROUTINE TRANSFER(N,X1,X2)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION X1(N),X2(N)
+ DO 1 I=1,N
+ 1 X2(I)=X1(I)
+ RETURN
+ END
+
projects / unres.git / blobdiff