Sources Esope | Cast3M

voisi2
C VOISI2    SOURCE    PV        11/03/07    21:18:41     6885
C=======================================================================
C
      SUBROUTINE VOISI2(T0,TP0,ZA0,VOIS2,IMARQ,ilent1,iele,igau)
C
C=======================================================================
C
C     Calcul de transformations de phases
C     appelee par TRPHA4
C
C     recherche des points supports pour l'interpolation
C
C     T0,TP0,ZA0      coordonnees du point a interpoler
C     VOIS2 /1,i=1-3  1er point voisin
C     VOIS2 /2,i=1-3  2eme point voisin
C     VOIS2 /3,i=1-3  3eme point voisin
C     VOIS2 /4,i=1-3  4eme point voisin
C     IPTAB           table materiau : ens des pts experimentaux
C     IMARQ           repere des pts trouves a la derniere recherche
C                     (solution initiale)
C
C     Les points voisins sont cherches pour les temperatures encadrant
C     directement T0
C     Ceux qui minimise la distance euclidienne sur les variables
C     TP et ZA sont retenus
C     Les ecarts sur TP et ZA ne sont pas ponderes, cela n'apportait
C     pas grand chose
C
C     routines appelees
C        TRITEM   tri dans la table des temperatures
C        TRIHIS   tri sur les histoires pour T donnee
C     Le tri se fait  a partir d'une solution initiale et recherche
C     finale par bissection
C
C     Michael Martinez 08/98
C
C=======================================================================
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC SMLENTI
-INC SMLREEL
C
      DIMENSION VOIS2(4,3)
C
      DIMENSION IMARQ(2)
      DIMENSION GR2(8,3)
C
      MLENTI = ILENT1
      segact mlenti
 
C
        NHIST=lect(/1)
 
        mlent2 = lect(1)
        segact mlent2*nomod
        NTEMP=mlent2.lect(/1)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    RECHERCHE DANS IPTAB DES EMPLACEMENTS ITINF0 ET ITSUP0 DES
C    DEUX TEMPERATURES ENCADRANT T0
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      ITINF0=IMARQ(1)
        if (iele.eq.1.and.igau.eq.1) then
*           write(6,*) imarq(1),ntemp
         endif
        CALL TRITE2 (ilent1,NTEMP,T0,ITINF0,ITSUP0)
      IMARQ(1)=ITINF0
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    RECHERCHE DES 4 PLUS PROCHES VOISINS POUR T=ITINF0
C    RECHERCHE DES 4 PLUS PROCHES VOISINS POUR T=ITSUP0
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IHINF=IMARQ(2)
      CALL TRIHI2 (ilent1,NHIST,ITINF0,IHINF,TP0,ZA0)
      IHSUP=IMARQ(2)
      CALL TRIHI2 (ilent1,NHIST,ITSUP0,IHSUP,TP0,ZA0)
      IMARQ(2)=IHINF
        if (iele.eq.1.and.igau.eq.1) then
*          write(6,*) itinf0,itsup0,ihinf,ihsup
        endif
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    ECRITURE DE CES VOISINS DANS UN TABLEAU
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      segact mlenti
         DO 1100 I=0,3
            mlent1 = lect(IHINF+I)
            segact mlent1
            mlreel = mlent1.lect(ITINF0)
            segact mlreel
                 tinf = prog(1)
                 TPINF=prog(2)
                 ZAINF=prog(3)
                 DIINF=((TPINF-TP0)**2.D0)+((ZAINF-ZA0)**2.D0)
        if (iele.eq.1.and.igau.eq.1) then
*          write(6,*) 'tr',tinf,tpinf,zainf
        endif
            segdes mlreel,mlent1
            GR2(1+I,1)=IHINF+I
            GR2(1+I,2)=ITINF0
            GR2(1+I,3)=DIINF
 1100    CONTINUE
C
         DO 1200 I=0,3
            mlent1 = lect(IHSUP+I)
            segact mlent1
            mlreel = mlent1.lect(ITSUP0)
            segact mlreel
                 TPSUP=prog(2)
                 ZASUP=prog(3)
                 DISUP=((TPSUP-TP0)**2.D0)+((ZASUP-ZA0)**2.D0)
            segdes mlreel,mlent1
            GR2(5+I,1)=IHSUP+I
            GR2(5+I,2)=ITSUP0
            GR2(5+I,3)=DISUP
 1200    CONTINUE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    CLASSEMENT DES VOISINS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
c      DO WHILE (GR2(1,3).GT.GR2(2,3).OR.GR2(2,3).GT.GR2(3,3)
c     .      .OR.GR2(3,3).GT.GR2(4,3).OR.GR2(4,3).GT.GR2(5,3)
c     .      .OR.GR2(5,3).GT.GR2(6,3).OR.GR2(6,3).GT.GR2(7,3)
c     .      .OR.GR2(7,3).GT.GR2(8,3))
1301  CONTINUE
      IF    (GR2(1,3).GT.GR2(2,3).OR.GR2(2,3).GT.GR2(3,3)
     .   .OR.GR2(3,3).GT.GR2(4,3).OR.GR2(4,3).GT.GR2(5,3)
     .   .OR.GR2(5,3).GT.GR2(6,3).OR.GR2(6,3).GT.GR2(7,3)
     .   .OR.GR2(7,3).GT.GR2(8,3)) THEN
         DO 1300 I=8,2,-1
            IF (GR2(I-1,3).GT.GR2(I,3)) THEN
               GAUX=GR2(I-1,1)
               TAUX=GR2(I-1,2)
               VAUX=GR2(I-1,3)
               GR2(I-1,1)=GR2(I,1)
               GR2(I-1,2)=GR2(I,2)
               GR2(I-1,3)=GR2(I,3)
               GR2(I,1)=GAUX
               GR2(I,2)=TAUX
               GR2(I,3)=VAUX
            ENDIF
1300     CONTINUE
      GOTO 1301
      END IF
c      END DO
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C    ON NE RETIENT QUE LES 4 PREMIERS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      VOIS2(1,1)=GR2(1,1)
      VOIS2(1,2)=GR2(1,2)
      VOIS2(1,3)=GR2(1,3)
      VOIS2(2,1)=GR2(2,1)
      VOIS2(2,2)=GR2(2,2)
      VOIS2(2,3)=GR2(2,3)
      VOIS2(3,1)=GR2(3,1)
      VOIS2(3,2)=GR2(3,2)
      VOIS2(3,3)=GR2(3,3)
      VOIS2(4,1)=GR2(4,1)
      VOIS2(4,2)=GR2(4,2)
      VOIS2(4,3)=GR2(4,3)
C
      RETURN
      END