Statistics
| Revision:

## root / src / Calc_zmat.f90 @ 5

 1  SUBROUTINE Calc_Zmat(na,atome,ind_zmat,val_zmat,x,y,z, &   r_cov, fact)   use Path_module, only : Pi,max_Z, NMaxL, Nom, KINT, KREAL   use Io_module, only : IoIn, IoOut   IMPLICIT NONE  ! Number of atoms   integer(KINT), INTENT(IN) :: na  ! Mass number of atoms   INTEGER(KINT), INTENT(IN) :: atome(na)  ! Coordinates   real(KREAL), INTENT(IN) :: x(na),y(na),z(na)  ! Covalent radii   REAL(KREAL), INTENT(IN) :: R_cov(Max_Z)  ! Factor to determine connectivity   REAL(KREAL) :: Fact  ! Zmat index and values   integer(KINT), INTENT(OUT) :: ind_zmat(na,5)   real(KREAL),INTENT(OUT) :: val_zmat(na,3)   INTEGER(KINT), ALLOCATABLE :: LIAISONS(:,:) !(na,0:NMaxL   INTEGER(KINT), ALLOCATABLE :: LiaisonsBis(:,:) ! na,0:NMaxL   INTEGER(KINT), ALLOCATABLE :: LieS_CP(:,:),LieS_CF(:,:) ! (na,0:NMaxL)   INTEGER(KINT), ALLOCATABLE :: NbAt3(:,:) !(Na,2)   INTEGER(KINT), ALLOCATABLE :: CycleAt(:) !(Na)   INTEGER(KINT), ALLOCATABLE :: CAFaire(:) ! Na   Integer(KINT) :: AtTypCycl(Max_Z)   Integer(KINT) :: NbCycle   real(KREAL) :: vx1,vy1,vz1,norm1   real(KREAL) :: vx2,vy2,vz2,norm2   real(KREAL) :: val   Logical PasFini,AtTerm,Debug,Bicycle,FLie3,FirstCycle   LOGICAL, ALLOCATABLE :: Former3(:), DejaFait(:) ! Na   Logical FTmp   LOGICAL F1213, F1223,F1323   INTEGER(KINT) :: I,J,K, IZM, N1,n2, N3, IL, JL   INTEGER(KINT) :: IdAt0, I3, IAt3, Idx3, I1, I0, IAf   INTEGER(KINT) :: Izm1,Izm2, IZm3,IZm4, VCF, ICat   INTEGER(KINT) :: IOld, IndFin, IdAtL, IndAFaire   INTEGER(KINT) :: IAti, IAtD, IAtv, IIAtDh, IAtDh   INTEGER(KINT) :: IAt0, IAta, IAt, Jat,Idx   INTEGER(KINT) :: ITmp, IAtTmp, NbAt0   INTEGER(KINT) :: NbLies, ICycle, IMax   REAL(KREAL) :: d,d12, d13,d32   INTERFACE   function valid(string) result (isValid)   CHARACTER(*), intent(in) :: string   logical :: isValid   END function VALID   FUNCTION angle(v1x,v1y,v1z,norm1,v2x,v2y,v2z,norm2)   use Path_module, only : Pi,KINT, KREAL   real(KREAL) :: v1x,v1y,v1z,norm1   real(KREAL) :: v2x,v2y,v2z,norm2   real(KREAL) :: angle   END FUNCTION ANGLE   END INTERFACE   debug=valid("Calc_zmat")   if (debug) WRITE(*,*) "========== Entering Calc_zmat =========="   FirstCycle=.TRUE.   FTmp=.FALSE.   NbCycle=0   DO i=1,na   DO J=1,5   Ind_Zmat(i,J)=0   END DO   END DO   ALLOCATE(Former3(Na), DejaFait(Na))   ALLOCATE(CaFaire(Na), CycleAt(Na))   ALLOCATE(NbAt3(Na,2))   ALLOCATE(Liaisons(na,0:NMaxL),LiaisonsBis(na,0:NMaxL))   ALLOCATE(Lies_CP(na,0:NMaxL), Lies_CF(na,0:NMaxL))   WRITE(IOOUT,*) Na   WRITE(IOOUT,*) 'Calc_zmat'   DO I=1,na   WRITE(IOOUT,*) NOM(Atome(I)),X(i),y(i),z(i)   END DO   if (na.le.2) THEN   WRITE(*,*) "I do not work for less than 2 atoms :-p"   RETURN   END IF  ! Cas particulier: 3 atomes ou moins...   if (Na.eq.3) THEN   d12=sqrt((x(1)-x(2))**2+(y(1)-y(2))**2+(z(1)-z(2))**2)   d13=sqrt((x(1)-x(3))**2+(y(1)-y(3))**2+(z(1)-z(3))**2)   d32=sqrt((x(3)-x(2))**2+(y(3)-y(2))**2+(z(3)-z(2))**2)   F1213=(d12<=d13)   F1323=(d13<=d32)   F1223=(d12<=d32)   if (debug) THEN   WRITE(*,*) "DEBUG Calc_Zmat 3 atoms"   WRITE(*,*) "d12,d13,d32:",d12,d13,d32   WRITE(*,*) "F1213,F1323,F1223:",F1213,F1323,F1223   END IF   if (F1213) THEN   if (F1323) THEN   ind_zmat(1,1)=3   ind_zmat(2,1)=1   ind_zmat(2,2)=3   ind_zmat(3,1)=2   ind_zmat(3,2)=1   ind_zmat(3,3)=3   ELSE   ind_zmat(1,1)=1   ind_zmat(2,1)=2   ind_zmat(2,2)=1   ind_zmat(3,1)=3   ind_zmat(3,2)=2   ind_zmat(3,3)=1   END IF   ELSE   IF (F1223) THEN   ind_zmat(1,1)=2   ind_zmat(2,1)=1   ind_zmat(2,2)=2   ind_zmat(3,1)=3   ind_zmat(3,2)=1   ind_zmat(3,3)=2   ELSE   ind_zmat(1,1)=2   ind_zmat(2,1)=3   ind_zmat(2,2)=2   ind_zmat(3,1)=1   ind_zmat(3,2)=3   ind_zmat(3,3)=2   END IF   END IF   IF (debug) THEN   DO i=1,na   WRITE(*,*) (ind_zmat(i,j),j=1,5)   END DO   END IF  ! We have ind_zmat, we fill val_zmat   val_zmat(1,1)=0.   val_zmat(1,2)=0.   val_zmat(1,3)=0.   n2=ind_zmat(2,1)   n1=ind_zmat(2,2)   d=sqrt((x(n1)-x(n2))**2+(y(n1)-y(n2))**2+ &   (z(n1)-z(n2))**2)   val_zmat(2,1)=d   val_zmat(2,2)=0.   val_zmat(2,3)=0.   n1=ind_zmat(3,1)   n2=ind_zmat(3,2)   n3=ind_zmat(3,3)   CALL vecteur(n2,n1,x,y,z,vx1,vy1,vz1,norm1)   if (debug) write(*,*) n1,n2,norm1   val_zmat(3,1)=norm1   CALL vecteur(n2,n3,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1,vx2,vy2,vz2,norm2)   if (debug) write(*,*) n2,n3,norm2,val   val_zmat(3,2)=val   val_zmat(3,3)=0.   RETURN   END IF  ! Premiere etape : calcul des connectivites   DO I=1,na   DejaFait(I)=.FALSE.   Former3(I)=.False.   Do J=0,NMaxL   Liaisons(I,j)=0   LiaisonsBis(I,j)=0   END DO   DO J=1,5   ind_zmat(I,J)=0   END DO   END DO   if (debug) WRITE(IOOUT,*) "Liaisons initialiazed"  ! DO IL=1,na  ! WRITE(IOOUT,1003) Il,(LIAISONS(IL,JL),JL=0,NMaxL)  ! WRITE(IOOUT,1003) Il,(LIAISONSBis(IL,JL),JL=0,NMaxL)  ! END DO   Call CalcCnct(na,atome,x,y,z,LIAISONS,r_cov,fact)   if (debug) THEN   WRITE(IOOUT,*) "Connections calculated"   DO IL=1,na   WRITE(IOOUT,1003) Il,(LIAISONS(IL,JL),JL=0,NMaxL)   END DO   END IF  ! on va maintenant trier ces connectivites en 2 :  ! Lies_CF : vers l'exterieur de la molecule  ! Lies_CP : vers l'interieur de la molecule  ! Pour cela, on procede 'a l'envers' : on regarde les atomes  ! auxquels sont lies les atomes attaches -> on remplit Lies_CF/P  ! et on supprime ces atomes...  ! v2.0 on copie Liaison dans LiaisonBis. On analyse LiaisonBis  ! tout en modifiant Liaison. Cela evite de fausser l'analyse: un atome  ! qui est lie initialement a 2 atomes (et qui n'est donc pas terminal)  ! peut devenir terminal en milieu de traitement si on annule la liaison  ! qui le liait a un atome terminal situ? avant lui...  ! ex: H2O code dans l'ordre H,O,H.   PasFini=.True.   AtTerm=.True.   DO WHILE (PasFini.AND.AtTerm)   PasFini=.False.   AtTerm=.False.   DO I=1,na   DO J=0,NMaxL   LiaisonsBis(I,J)=Liaisons(I,J)   END DO   END DO  ! DO IL=1,na  ! WRITE(IOOUT,1003) Il,(LIAISONS(IL,JL),JL=0,NMaxL)  ! WRITE(IOOUT,1003) Il,(LIAISONSBis(IL,JL),JL=0,NMaxL)  ! END DO  ! WRITE(IOOUT,*) "=================================="   DO I=1,na   if ((LiaisonsBis(I,0).eq.1).AND.Liaisons(I,0).ne.0) THEN   AtTerm=.True.  ! On enleve cet atome   Liaisons(I,0)=0   NbLies=Lies_CP(I,0)+1   Lies_CP(I,NbLies)=Liaisons(I,1)   Lies_CP(I,0)=NbLies   Liaisons(Liaisons(I,1),0)=Liaisons(Liaisons(I,1),0)-1   NbLies=Lies_CF(Liaisons(I,1),0)+1   Lies_CF(Liaisons(I,1),NbLies)=I   Lies_CF(Liaisons(I,1),0)=NbLies   Call Annul(Liaisons,Liaisons(I,1),I)   END IF   if (Liaisons(I,0).ge.1) THEN   PasFini=.TRUE.   END IF   END DO   if (debug) WRITE(*,*) 'PasFini, AtTerm',PasFini,AtTerm   If (PasFini.AND.(.Not.AtTerm)) THEN  ! Pas d'atomes terminaux lors de l'exploration precedente.  ! On a soit une erreur, soit un cycle. Je ne sais pas encore gerer  ! tous les cas : on affiche un warning   WRITE(*,*) "Je ne trouve pas d'atomes terminaux"   WRITE(*,*) "Possibilite de molecule cyclique"   WRITE(*,*) "Cas en cours de traitement: verifier l'output"  ! On va d'abord voir si on a des atomes li?s a plus de 2 centres.   AtTerm=.TRUE.   Bicycle=.False.   ICycle=0   IMax=0   DO I=1,na   if (Liaisons(I,0).gt.2) THEN   ICycle=ICycle+1   BiCycle=.True.   If (Liaisons(I,0).gt.IMax) Imax=Liaisons(I,0)   Former3(I)=.True.   END IF   END DO   IF (BiCycle) THEN  ! On a des atomes lies a 3 ou plus d'atomes...  ! donc soit des bicycles, soit plusieurs  ! cycles attaches par un sommet...   WRITE(*,*) "On dirait un bicyle... on essaie"   WRITE(*,*) ICycle, "atomes lies a plus de 2 atomes"   WRITe(*,*) "Nb Attaches max:",IMax  ! Plusieurs cas possibles pour un bicycle:  ! 1) 2 cycles relies par un sommet, ICycle=2, IMax=3  ! 2) 2 cycles relies par une arrete, ICycle=2, Imax=3   If (Imax.Eq.3) THEN  ! on doit pouvoir traiter celui la...  ! On classe les atomes li?s a trois atomes, par le nombre d'atomes  ! lies a trois atomes  ! auxquels ils sont li?s ... interessant pour les composes asterisques.   I3=0   FLie3=.False.   DO I=1,Na   If (Liaisons(I,0).EQ.3) THEN   I3=I3+1   K=0   DO J=1,Liaisons(I,0)   If (Liaisons(Liaisons(I,J),0).Eq.3) THEN   k=k+1   FLie3=.True.   END IF   END DO   NbAt3(I3,2)=k   NbAt3(I3,1)=I   END IF   END DO  ! A-t-on deux atomes a 3 lies ensemble ?   IF (FLie3) THEN  ! on les classe pas nb at lies a 3   IAt3=0   Idx3=0   DO I=1,I3   IF (NbAt3(I,2).ge.Iat3) THEN   IAt3=NbAt3(I,2)   Idx3=NbAt3(I,1)   END IF   END DO  ! On va enlever ces liaisons entre atomes a 3, en les mettant  ! en CF de l'atome 'central'   if (debug) WRITE(*,*) "Atome ",Idx3, &   " retenu, li? a",IAt3," atomes 3"   DO I=1,Liaisons(Idx3,0)   I1=Liaisons(Idx3,I)   If (Liaisons(I1,0).EQ.3) THEN   if (debug) WRITE(*,*) "Traitement ",I1,Idx3   NbLies=Lies_CF(Idx3,0)+1   Lies_CF(Idx3,NbLies)=I1   Lies_CF(Idx3,0)=NbLies   NbLies=Lies_CP(I1,0)+1   Lies_CP(I1,NbLies)=Idx3   Call Annul(Liaisons,I1,Idx3)   Call Annul(Liaisons,Idx3,I1)   Liaisons(Idx3,0)=Liaisons(Idx3,0)-1   Liaisons(I1,0)=Liaisons(I1,0)-1   END IF   END DO   ELSE   WRITE(*,*) "Aucune liaisons entre deux atomes li?s"   WRITE(*,*) "Pas encore trait?"   STOP   END IF !FLie3=T ?   END IF !Imax=3 ?   ELSE ! BiCyle ?  ! Un seul cycle. Facile :-)   WRITE(*,*) "Un cycle identifie..."   NbCycle=NbCycle+1   if (debug) WRITE(*,*) 'Considering cycle ',NbCycle   If (NbCycle.ge.2) THEN  ! si ce n'est pas le premier cycle que l'on met, on regarde si parmi les  ! atomes du cycle, l'un d'eux etait avant attache a 3 atomes...   I=1   DO WHILE (Liaisons(I,0).ne.2)   I=I+1   END DO   if (debug) WRITE(*,*) "I>2:",I,Former3(I)   FTmp=Former3(I)   I0=I   IOld=I   I1=I   I=Liaisons(I,1)   DO WHILE (.NOT.FTmp)   I1=Liaisons(I,1)   If (I1.Eq.IOld) I1=Liaisons(I,2)   FTmp=Former3(I1)   if (debug) WRITE(*,*) "I,I1,I0,IOld",I,I1,I0, &   IOld,FTmp   IF (I1.eq.I0) FTmp=.TRUE.   if (debug) WRITE(*,*) "I,I1,I0,IOld",I,I1,I0, &   IOld,FTmp   IOld=I   I=I1   END DO   if (debug) WRITE(*,*) "I,I1,I0,IOld",I,I1,I0, &   IOld,FTmp   IF (Former3(I1)) THEN  ! On a notre atome particulier ... cool :-)   if (debug) WRITE(*,*) "Atome former3",I1   ITmp=I1   END IF   END IF ! NbCycle >=2   IF (.NOT.Ftmp) THEN   if (debug) WRITE(*,*) "Pas trouve de former3"  ! on regarde si il y a un atome particulier.. ie un heteroatome ou autre.   DO I=1,Max_Z   AtTypCycl(I)=0   END DO   DO I=1,na   if (Liaisons(I,0).eq.2) &   AtTypCycl(Atome(I))=AtTypCycl(Atome(I))+1   if (debug) WRITE(*,*) I,Atome(I), &   AtTypCycl(Atome(I)), &   Liaisons(I,0)   END DO   Itmp=NmaxL+1   IAtTmp=0   DO I=1,Max_Z   If ((AtTypCycl(I).gt.0).and.(AtTypCycl(I).le.Itmp)) &   THEN   Itmp=AtTypCycl(I)   IAtTmp=I   END IF   END DO   if (debug) WRITE(*,*) 'Itmp,IAtTmp:',Itmp,IAtTmp  ! On a le type de l'atome particulier... on va prendre le premier venu   DO I=na,1,-1   If ((Atome(I).eq.IAtTmp).AND.(Liaisons(I,0).Eq.2)) &   Itmp=I   END DO   END IF   if (debug) WRITE(*,*) 'Atome ',Itmp,'(',IAtTmp,') retenu'  ! On va tricher en enlevant les liaisons de cet atome a la main...   I0=Itmp   I1=Liaisons(I0,1)   DO WHILE (I1.Ne.ITmp)   if (debug) WRITE(*,*) "Going from",I0,"to ",I1  ! On rajoute ces deux liaisons en CF de Itmp   NbLies=Lies_CF(I0,0)+1   Lies_CF(I0,NbLies)=Liaisons(I0,1)   Lies_CF(I0,0)=NbLies  ! et les liaisons vers Itmp deviennent des CP pour les autres atomes   NbLies=Lies_CP(I1,0)+1   Lies_CP(I1,NbLies)=I0   Lies_CP(I1,0)=NbLies   Call Annul(Liaisons,I1,I0)   Liaisons(I1,0)=Liaisons(I1,0)-1   Liaisons(I0,0)=Liaisons(I0,0)-1   DO IL=1,na   WRITE(IOOUT,1003) Il,(LIAISONS(IL,JL),JL=0,NMaxL)   END DO   I0=I1   I1=Liaisons(I0,1)   end do   Call Annul(Liaisons,I1,I0)   Liaisons(I1,0)=Liaisons(I1,0)-1   Liaisons(I0,0)=Liaisons(I0,0)-1   END IF   END IF   DO IL=1,na   WRITE(IOOUT,1003) Il,(LIAISONS(IL,JL),JL=0,NMaxL)   END DO  ! WRITE(IOOUT,*) "=================================="  ! WRITE(IOOUT,*) "=================================="   END DO  ! WRITE(IOOUT,*) "=================================="  ! Il ne reste plus que des atomes lies a rien...  ! ce sont les 'centres' de la molecule. On repart  ! d'eux pour construire le reste de la molecule.   1003 FORMAT(1X,I4,' - ',15(I5))  ! Avant de partir, on va classer, pour chaque atome, les atomes CF par  ! nombre de masse decroissant.   DO I=1,na  ! WRITE(*,*) I,Lies_CF(I,0),(Atome(Lies_CF(I,J)),j=1,Lies_CF(I,0))   DO J=1,Lies_CF(I,0)-1   DO K=J+1,Lies_CF(I,0)   if (atome(Lies_CF(I,K))>atome(Lies_CF(I,J))) THEN   Itmp=Lies_CF(I,K)   Lies_CF(I,K)=Lies_CF(I,J)   Lies_CF(I,J)=Itmp   END IF   END DO   END DO  ! WRITE(*,*) I,Lies_CF(I,0),(Atome(Lies_CF(I,J)),j=1,Lies_CF(I,0))   END DO   IF (Debug) THEN   WRITE(IOOUT,*) 'LIAISONS'   DO I=1,na   WRITE(IOOUT,1003) i,(LIAISONS(I,J),J=0,NMaxL)   END DO   WRITE(IOOUT,*) 'LIes_CF'   DO I=1,na   WRITE(IOOUT,1003) i,(LIeS_CF(I,J),J=0,NMaxL)   END DO   WRITE(IOOUT,*) 'LIes_CP'   DO I=1,na   WRITE(IOOUT,1003) i,(LIeS_CP(I,J),J=0,NMaxL)   END DO   END IF  ! On compte le nb d'atomes sans atomes CP (centripetes)   NbAt0=0   DO I=1,na   IF (Lies_CP(I,0).eq.0) THEN   NbAt0=NbAt0+1   IF (DEBUG) WRITE(*,*) "Center atom",NbAt0,I,Atome(I)   END IF   END DO  ! On va les traiter tous en construisant les molecules en partant d'eux  ! Le premier atome sans CP est different des autres car il fixe  ! l'origine   IZm=1  ! Boucle pour trouver celui qui a le plus d'atomes CF   IdAt0=0   VCF=0   DO ICAt=1,na   if ((Lies_CP(ICaT,0).eq.0).AND.(Lies_CF(ICAt,0).gt.VCF)) THEN   IdAt0=ICat   VCF=Lies_CF(ICAt,0)   END IF   END DO   Lies_CP(IdAt0,0)=-1  ! WRITE(IOOUT,*) 'Atome 1', IdAt0, Nom(Atome(IdAt0))   Izm1=IdAt0   ind_zmat(izm,1)=Izm1   ind_zmat(izm,2)=0   ind_zmat(izm,3)=0   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=0.0   val_zmat(izm,2)=0.0   val_zmat(izm,3)=0.0   DejaFait(Izm1)=.True.  ! Les atomes CF lies a IdAt0 sont mis en attente pour  ! etre traites   IndFin=1   Do iaf=1,Lies_CF(IdAt0,0)   CAfaire(IndFin)=Lies_CF(IdAt0,Iaf)   IndFin=IndFin+1   END DO   CAfaire(IndFin)=0  ! On construit la premiere couche qui est speciale car elle fixe les  ! axes.  ! Plusieurs cas sont possibles suivant le nb d'atomes CF   IF (Lies_CF(IdAt0,0).ge.3) THEN   if (debug) WRITE(*,*) 'Cas tres simple,',IdAt0, &   ' li? a plus de 3 atomes'   IZm2=Lies_CF(IdAt0,1)   IZm3=Lies_CF(IdAt0,2)  ! WRITE(IOOUT,*) 'Atome 2' , Izm2, Nom(Atome(Izm2))  ! WRITE(IOOUT,*) 'Atome 3' ,Izm3, Nom(Atome(izm3))   Izm=2   CALL vecteur(IZm1,IZm2,x,y,z,vx1,vy1,vz1,norm1)  ! write(*,11) n1,n2,norm1   ind_zmat(izm,1)=izm2   ind_zmat(izm,2)=izm1   ind_zmat(izm,3)=0   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm1   val_zmat(izm,2)=0.0   val_zmat(izm,3)=0.0   DejaFait(Izm2)=.TRUE.   Izm=3   CALL vecteur(izm1,izm3,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1,vx2,vy2,vz2,norm2)  ! write(*,11) n1,n2,norm1,n3,val   ind_zmat(izm,1)=izm3   ind_zmat(izm,2)=izm1   ind_zmat(izm,3)=izm2   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm2   val_zmat(izm,2)=val   val_zmat(izm,3)=0.0   DejaFait(Izm3)=.TRUE.   DO IdAtl=3,Lies_CF(IdAt0,0)   Izm4= Lies_CF(IdAt0,IdAtl)  ! WRITE(IOOUT,*) 'Atome ',Izm+1,Izm4,Nom(Atome(Izm4)),Izm1,  ! $Izm2,Izm3   Izm=Izm+1   Call AddLigne(Izm,Izm4,Izm1,Izm2,Izm3,ind_zmat,val_zmat, &   x,y,z)   DejaFait(Izm4)=.TRUE.   END DO   END IF   IF (Lies_CF(Izm1,0).eq.2) THEN   if (debug) WRITE(*,*) 'Cas simple,',IdAt0, &   ' li? a 2 atomes'   IZm2=Lies_CF(IdAt0,1)   IZm3=Lies_CF(IdAt0,2)   Izm=2   CALL vecteur(IZm1,IZm2,x,y,z,vx1,vy1,vz1,norm1)  ! write(*,11) n1,n2,norm1   ind_zmat(izm,1)=izm2   ind_zmat(izm,2)=izm1   ind_zmat(izm,3)=0   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm1   val_zmat(izm,2)=0.0   val_zmat(izm,3)=0.0   DejaFait(Izm2)=.TRUE.   Izm=3   CALL vecteur(izm1,izm3,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1, &   vx2,vy2,vz2,norm2)  ! write(*,11) n1,n2,norm1,n3,val   ind_zmat(izm,1)=izm3   ind_zmat(izm,2)=izm1   ind_zmat(izm,3)=izm2   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm2   val_zmat(izm,2)=val   val_zmat(izm,3)=0.0   DejaFait(Izm3)=.TRUE.   END IF   IF (Lies_CF(Izm1,0).eq.1) THEN   if (debug) WRITE(*,*) 'Cas merdouille,',IdAt0, &   ' li? a 1 atome'   IZm2=Lies_CF(IdAt0,1)   Izm=2   CALL vecteur(IZm1,IZm2,x,y,z,vx1,vy1,vz1,norm1)  ! write(*,11) n1,n2,norm1   ind_zmat(izm,1)=izm2   ind_zmat(izm,2)=izm1   ind_zmat(izm,3)=0   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm1   val_zmat(izm,2)=0.0   val_zmat(izm,3)=0.0   DejaFait(Izm2)=.TRUE.  ! Pour les autres atomes, on prend les atomes  ! CF lie a l'tome CF lie a At0... en esperant  ! qu'il en a !!!  ! => il faudra voir le cas ou il n'en a pas !!!  ! en attendant on rajoute le test...   IF (Lies_CF(Izm2,0).Eq.0) THEN   WRITE(*,*) "Je n'arrive pas a trouver les premiers"   WRITE(*,*) "atomes pour construire la molecule"   WRITE(*,*) "Atome central li? au plus a 1 atome",Izm1,izm2   WRITE(*,*) "Et atome 2 li? a rien... moi perdu"   STOP   END IF  ! On ajoute les atomes lies a cet atome dans la liste a faire   Do iaf=1,Lies_CF(Izm2,0)   CAfaire(IndFin)=Lies_CF(Izm2,Iaf)   IndFin=IndFin+1   END DO   CAfaire(IndFin)=0   Izm3= Lies_CF(Izm2,1)   Izm=3   CALL vecteur(izm2,izm1,x,y,z,vx1,vy1,vz1,norm1)   CALL vecteur(izm2,izm3,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1, &   vx2,vy2,vz2,norm2)  ! write(*,11) n1,n2,norm1,n3,val   ind_zmat(izm,1)=izm3   ind_zmat(izm,2)=izm2   ind_zmat(izm,3)=izm1   ind_zmat(izm,4)=0   ind_zmat(izm,5)=0   val_zmat(izm,1)=norm1   val_zmat(izm,2)=val   val_zmat(izm,3)=0.0   DejaFait(Izm3)=.TRUE.  ! je pense que ce qui suit est totalement inutile  ! C DO IdAtl=3,Lies_CF(IdAt0,0)  ! C Izm4= Lies_CF(IdAt0,IdAtl)  ! C Izm=Izm+1  ! C Call AddLigne(Izm,Izm4,Izm1,Izm2,Izm3,ind_zmat,val_zmat  ! C$,x,y,z)  ! C DejaFait(Izm4)=.TRUE.  ! C END DO   END IF  ! on a cree la premiere couche autour du premier centre  ! reste a finir les autres couches   IndAFaire=1   if (debug) WRITE(IOOUT,*) "CaFaire:",CaFaire   Do WHILE (Cafaire(IndAFaire).ne.0)   IAt0=Cafaire(IndAfaire)   if (debug) WRITE(*,*) "IndAFaire,IAt0,Lies_CF(IAt0,0)", &   IndAFaire,IAt0,Lies_CF(IAt0,0)   if (Lies_CF(IAt0,0).ge.1) THEN  ! IAt0 est l'atome pour lequel on construit la couche suivante  ! le premier atome lie est particulier car il definit l'orientation  ! de ce fragment   IAti=Lies_CF(IAt0,1)  ! WRITE(IOOUT,*) 'IAti:',IAti   IAtd=IAt0  ! WRITE(IOOUT,*) 'IAtd:',IAtd   IAtv=Lies_CP(IAt0,1)  ! WRITE(IOOUT,*) 'IAtv:',IAtv   IIAtdh=1   IAtdh=Lies_CF(IAtv,IIatdh)   DO WHILE (Iatdh.eq.IAt0)   IIatdh=IIatdh+1   IAtdh=Lies_CF(IAtv,IIatdh)   END DO   IF (IAtdh.eq.0) IAtdh=Lies_CP(IAtv,1)  ! WRITE(IOOUT,*) 'IAtdh:',IAtdh   IF (.NOT.DejaFait(IAti)) THEN   Izm=Izm+1   if (debug) WRITE(*,*) 'izm,IAti,IAtd,IAtv,IAtdh', &   izm,IAti,IAtd,IAtv,IAtdh   Call AddLigne(Izm,IAti,IAtd,IAtv,IAtdh,ind_zmat,val_zmat &   ,x,y,z)   DejaFait(IAti)=.TRUE.   END IF   CAfaire(IndFin)=Lies_CF(IAt0,1)   IndFin=IndFin+1  ! Le traitement des autres est plus facile   IAtdh=Lies_CF(IAt0,1)   DO IAta=2,Lies_CF(IAt0,0)   IAtI=Lies_CF(IAt0,IAta)   if (debug) WRITE(*,*) " Problem is here; IndFin:",I   CAfaire(IndFin)=IAtI   IndFin=IndFin+1   IF (.NOT.DejaFait(IAti)) THEN   Izm=Izm+1   Call AddLigne(Izm,IAti,IAtd,IAtv,IAtdh,ind_zmat &   ,val_zmat,x,y,z)   DejaFait(IAti)=.TRUE.   END IF   END DO   CAfaire(IndFin)=0   END IF   IndAFaire=IndAFaire+1   END DO  ! On a fini de creer la molecule autour du premier atome 'centre'  ! Pour les autres c'est presque id... sauf que les axes sont deja fixes  ! On pourrait imaginer de mettre des atomes fictifs pour redefinir des axes  ! locaux... dans une autre version  ! V2.0   NbAt0=NbAt0-1   DO I=1,NbAt0  ! Boucle pour trouver celui qui a le plus d'atomes CF   IdAt0=0   VCF=0   DO ICAt=1,na   if ((Lies_CP(ICaT,0).eq.0).AND.(Lies_CF(ICAt,0).gt.VCF)) &   THEN   IdAt0=ICat   VCF=Lies_CF(ICAt,0)   END IF   END DO   Lies_CP(IdAt0,0)=-1   IF (debug) WRITE(*,*) 'Adding fragment centered on ',IdAt0, &   LIAISONS(IdAt0,0)   IF (debug) WRITE(*,*) 'Center linked to ',Lies_CF(IdAt0,0), &   ' atoms'  ! if (LIAISONS(IdAt0,0).EQ.0) goto 12345   if (debug) THEN   WRITE(IOOUT,*) 'LIAISONS tralala',nbcycle   DO IAt=1,na   WRITE(IOOUT,1003) iat,(LIAISONS(Iat,Jat),Jat=0,NMaxL)   END DO   END IF  ! Boucle pour voir quel est l'atome du fragment precedent qui est le plus  ! proche de celui ci  ! Rq: si ce sont des cycles lies, il pourrait etre malin de rechercher  ! a quoi il etait lie.   norm2=1.e6   Idx=0   DO ICAt=1,Izm   CALL vecteur(Idat0,ind_zmat(icat,1),x,y,z,vx1,vy1,vz1,norm1)   if (norm2.ge.norm1) THEN   norm2=norm1   Idx=Icat   END IF   END DO   IF (debug) WRITE(*,*) 'Link between fragments ',IdAt0, &   ind_zmat(Idx,1), ' -- Idx=',Idx  ! on a l'indice... on va rajouter cet atome a la liste !   izm=izm+1   n1=ind_zmat(Idx,1)  ! Petit probleme si Idx<=2   IF (Idx.EQ.1) THEN  ! Pb non negligeable ...   IF (izm.ge.2) THEN   IAtv=ind_zmat(2,1)   IAtdh=ind_zmat(3,1)   ELSE   WRITE(*,*) '2 fragments, le 1er a moins de 2 atomes...'   WRITE(*,*) "J'ai merde... "   STOP   END IF   ELSEIF (Idx.EQ.2) THEN   IAtv=1   IF (izm.ge.2) THEN   IAtdh=ind_zmat(3,1)   ELSE   WRITE(*,*) '2 fragments, le 1er a moins de 2 atomes...'   WRITE(*,*) "J'ai merde... "   STOP   END IF   ELSE   IAtv=ind_zmat(Idx,2)   IAtdh=ind_zmat(Idx,3)   END IF  ! WRITE(*,*) "Outchilou IAtv, IAtdh", IAtv, IAtdh,n1   CALL vecteur(n1,IdAt0,x,y,z,vx1,vy1,vz1,norm1)   CALL vecteur(n1,IAtv,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1, &   vx2,vy2,vz2,norm2)   if (debug) WRITE(*,*) 'Angle val:1',IdAt0,n1,IAtv,val   if ((abs(val).LE.10.).OR.(abs(pi-val).le.10.)) THEN   IAtv=IAtdh  ! Ceci pose pb si Idx<=3... a traiter plus tard   IF (Idx.ge.3) THEN   IAtdh=ind_zmat(Idx,4)   ELSE   if (izm.ge.4) THEN   IAtdh=4   ELSE   WRITE(*,*) 'Pb Angle Val+idx=3+izm<=4'   STOP   END IF   END IF   END IF   Call AddLigne(Izm,IdAt0,ind_zmat(Idx,1),IAtv,IAtdh, &   ind_zmat,val_zmat,x,y,z)   IndFin=1   IAtd=IdAt0   n1=IAtdh   IAtdh=IAtv   IAtv=ind_zmat(Idx,1)  ! On ajoute les atomes lies a cet atome dans la liste a faire   Do iaf=1,Lies_CF(IdAt0,0)   IatI=Lies_CF(IdAt0,Iaf)  ! We check that this atom is not the one that is the closest to  ! the center atom   if (IAtv.Ne.IAtI) THEN   IF (debug) WRITE(*,*) 'Adding atom',IAtI, &   'to CAFaire in pos',iaf   CAfaire(IndFin)=IAtI   IndFin=IndFin+1  ! On les ajoute aussi dans la zmat   If (.NOT.DejaFait(IatI)) THEN   izm=izm+1  ! WRITE(*,*) "Outchili IAtv, IAtdh,IAtI", IAtv, IAtdh,IAtI   CALL vecteur(IAtI,IAtD,x,y,z,vx1,vy1,vz1,norm1)   CALL vecteur(IAtI,IAtv,x,y,z,vx2,vy2,vz2,norm2)   val=angle(vx1,vy1,vz1,norm1, vx2,vy2,vz2,norm2)   if (debug) WRITE(*,*) 'Angle val:2',IAtI,IAtD,IAtv,val   if ((abs(val).LE.10.).OR.(abs(180.-abs(val)).le.10.)) &   THEN   Call AddLigne(Izm,IAtI,IAtv,IAtdh,n1, &   ind_zmat,val_zmat,x,y,z)   ELSE   Call AddLigne(Izm,IAtI,IAtD,IAtv,IAtdh, &   ind_zmat,val_zmat,x,y,z)   END IF   END IF   END IF   END DO   CAfaire(IndFin)=0  ! On traite le reste de ce fragment !!   IndAFaire=1   WRITE(IOOUT,*) CaFaire   Do WHILE (Cafaire(IndAFaire).ne.0)   IAt0=Cafaire(IndAfaire)   if (Lies_CF(IAt0,0).ge.1) THEN  ! IAt0 est l'atome pour lequel on construit la couche suivante  ! le premier atome lie est particulier car il definit l'orientation  ! de ce fragment   Itmp=1   IAti=Lies_CF(IAt0,Itmp)   DO WHILE (DejaFait(IAti).AND.(Itmp.Le.Lies_CF(IAt0,0)))   Itmp=Itmp+1   IAti=Lies_CF(IAt0,ITmp)   END DO   If (.NOT.DejaFait(Iati)) THEN   IF (debug) WRITE(IOOUT,*) 'IAti:',IAti   IAtd=IAt0   IF (debug) WRITE(IOOUT,*) 'IAtd:',IAtd   IAtv=Lies_CP(IAt0,1)   IF (debug) WRITE(IOOUT,*) 'IAtv:',IAtv   IIAtdh=1   IAtdh=Lies_CF(IAtv,IIatdh)   DO WHILE (Iatdh.eq.IAt0)   IIatdh=IIatdh+1   IAtdh=Lies_CF(IAtv,IIatdh)   END DO   IF (IAtdh.eq.0) IAtdh=Lies_CP(IAtv,1)   IF (debug) WRITE(IOOUT,*) 'IAtdh:',IAtdh   Izm=Izm+1   Call AddLigne(Izm,IAti,IAtd,IAtv,IAtdh, &   ind_zmat,val_zmat,x,y,z)  ! Le traitement des autres est plus facile   IAtdh=Lies_CF(IAt0,ITmp)   DO IAta=ITmp+1,Lies_CF(IAt0,0)   IAtI=Lies_CF(IAt0,IAta)   If (.NOT.DejaFait(IAtI)) THEN   Izm=Izm+1   Call AddLigne(Izm,IAti,IAtd,IAtv,IAtdh, &   ind_zmat,val_zmat,x,y,z)   END IF   END DO   END IF  ! On ajoute les atomes lies a cet atome dans la liste a faire   Do iaf=1,Lies_CF(IAt0,0)   CAfaire(IndFin)=Lies_CF(IAt0,Iaf)   IndFin=IndFin+1   END DO   CAfaire(IndFin)=0   END IF   IndAFaire=IndAFaire+1   END DO  !12345 CONTINUE   END DO   if (debug) THEN   WRITE(*,*) 'ind_zmat'   DO I=1,na   WRITE(*,'(1X,5I5)') (ind_zmat(i,j),j=1,5)   END DO   END IF   if (debug) WRITE(*,*) "====================== Exiting Calc_zmat ==================="   END SUBROUTINE Calc_Zmat