1 : C VOISI2 SOURCE PV 11/03/07 21:18:41 6885 2 : C======================================================================= 3 : C 4 : SUBROUTINE VOISI2(T0,TP0,ZA0,VOIS2,IMARQ,ilent1,iele,igau) 5 : C 6 : C======================================================================= 7 : C 8 : C Calcul de transformations de phases 9 : C appelee par TRPHA4 10 : C 11 : C recherche des points supports pour l'interpolation 12 : C 13 : C T0,TP0,ZA0 coordonnees du point a interpoler 14 : C VOIS2 /1,i=1-3 1er point voisin 15 : C VOIS2 /2,i=1-3 2eme point voisin 16 : C VOIS2 /3,i=1-3 3eme point voisin 17 : C VOIS2 /4,i=1-3 4eme point voisin 18 : C IPTAB table materiau : ens des pts experimentaux 19 : C IMARQ repere des pts trouves a la derniere recherche 20 : C (solution initiale) 21 : C 22 : C Les points voisins sont cherches pour les temperatures encadrant 23 : C directement T0 24 : C Ceux qui minimise la distance euclidienne sur les variables 25 : C TP et ZA sont retenus 26 : C Les ecarts sur TP et ZA ne sont pas ponderes, cela n'apportait 27 : C pas grand chose 28 : C 29 : C routines appelees 30 : C TRITEM tri dans la table des temperatures 31 : C TRIHIS tri sur les histoires pour T donnee 32 : C Le tri se fait a partir d'une solution initiale et recherche 33 : C finale par bissection 34 : C 35 : C Michael Martinez 08/98 36 : C 37 : C======================================================================= 38 : C 39 : IMPLICIT INTEGER(I-N) 40 : IMPLICIT REAL*8(A-H,O-Z) 41 : C 42 : -INC SMLENTI 43 : -INC SMLREEL 44 : C 45 : DIMENSION VOIS2(4,3) 46 : C 47 : DIMENSION IMARQ(2) 48 : DIMENSION GR2(8,3) 49 : C 50 : MLENTI = ILENT1 51 : segact mlenti 52 : 53 : C 54 : NHIST=lect(/1) 55 : 56 : mlent2 = lect(1) 57 : segact mlent2*nomod 58 : NTEMP=mlent2.lect(/1) 59 : C 60 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 61 : C RECHERCHE DANS IPTAB DES EMPLACEMENTS ITINF0 ET ITSUP0 DES 62 : C DEUX TEMPERATURES ENCADRANT T0 63 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 64 : C 65 : ITINF0=IMARQ(1) 66 : if (iele.eq.1.and.igau.eq.1) then 67 : * write(6,*) imarq(1),ntemp 68 : endif 68 : CALL TRITE2 (ilent1,NTEMP,T0,ITINF0,ITSUP0) 69 : IMARQ(1)=ITINF0 70 : C 71 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 72 : C RECHERCHE DES 4 PLUS PROCHES VOISINS POUR T=ITINF0 73 : C RECHERCHE DES 4 PLUS PROCHES VOISINS POUR T=ITSUP0 74 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 75 : C 76 : IHINF=IMARQ(2) 76 : CALL TRIHI2 (ilent1,NHIST,ITINF0,IHINF,TP0,ZA0) 77 : IHSUP=IMARQ(2) 77 : CALL TRIHI2 (ilent1,NHIST,ITSUP0,IHSUP,TP0,ZA0) 78 : IMARQ(2)=IHINF 79 : if (iele.eq.1.and.igau.eq.1) then 80 : * write(6,*) itinf0,itsup0,ihinf,ihsup 81 : endif 82 : C 83 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 84 : C ECRITURE DE CES VOISINS DANS UN TABLEAU 85 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 86 : C 87 : segact mlenti 88 : DO 1100 I=0,3 89 : mlent1 = lect(IHINF+I) 90 : segact mlent1 91 : mlreel = mlent1.lect(ITINF0) 92 : segact mlreel 93 : tinf = prog(1) 94 : TPINF=prog(2) 95 : ZAINF=prog(3) 96 : DIINF=((TPINF-TP0)**2.D0)+((ZAINF-ZA0)**2.D0) 97 : if (iele.eq.1.and.igau.eq.1) then 98 : * write(6,*) 'tr',tinf,tpinf,zainf 99 : endif 100 : segdes mlreel,mlent1 101 : GR2(1+I,1)=IHINF+I 102 : GR2(1+I,2)=ITINF0 103 : GR2(1+I,3)=DIINF 104 : 1100 CONTINUE 105 : C 106 : DO 1200 I=0,3 107 : mlent1 = lect(IHSUP+I) 108 : segact mlent1 109 : mlreel = mlent1.lect(ITSUP0) 110 : segact mlreel 111 : TPSUP=prog(2) 112 : ZASUP=prog(3) 113 : DISUP=((TPSUP-TP0)**2.D0)+((ZASUP-ZA0)**2.D0) 114 : segdes mlreel,mlent1 115 : GR2(5+I,1)=IHSUP+I 116 : GR2(5+I,2)=ITSUP0 117 : GR2(5+I,3)=DISUP 118 : 1200 CONTINUE 119 : C 120 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 121 : C CLASSEMENT DES VOISINS 122 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 123 : C 124 : c DO WHILE (GR2(1,3).GT.GR2(2,3).OR.GR2(2,3).GT.GR2(3,3) 125 : c . .OR.GR2(3,3).GT.GR2(4,3).OR.GR2(4,3).GT.GR2(5,3) 126 : c . .OR.GR2(5,3).GT.GR2(6,3).OR.GR2(6,3).GT.GR2(7,3) 127 : c . .OR.GR2(7,3).GT.GR2(8,3)) 128 : 1301 CONTINUE 129 : IF (GR2(1,3).GT.GR2(2,3).OR.GR2(2,3).GT.GR2(3,3) 130 : . .OR.GR2(3,3).GT.GR2(4,3).OR.GR2(4,3).GT.GR2(5,3) 131 : . .OR.GR2(5,3).GT.GR2(6,3).OR.GR2(6,3).GT.GR2(7,3) 132 : . .OR.GR2(7,3).GT.GR2(8,3)) THEN 133 : DO 1300 I=8,2,-1 134 : IF (GR2(I-1,3).GT.GR2(I,3)) THEN 135 : GAUX=GR2(I-1,1) 136 : TAUX=GR2(I-1,2) 137 : VAUX=GR2(I-1,3) 138 : GR2(I-1,1)=GR2(I,1) 139 : GR2(I-1,2)=GR2(I,2) 140 : GR2(I-1,3)=GR2(I,3) 141 : GR2(I,1)=GAUX 142 : GR2(I,2)=TAUX 143 : GR2(I,3)=VAUX 144 : ENDIF 145 : 1300 CONTINUE 146 : GOTO 1301 147 : END IF 148 : c END DO 149 : C 150 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 151 : C ON NE RETIENT QUE LES 4 PREMIERS 152 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 153 : C 154 : VOIS2(1,1)=GR2(1,1) 155 : VOIS2(1,2)=GR2(1,2) 156 : VOIS2(1,3)=GR2(1,3) 157 : VOIS2(2,1)=GR2(2,1) 158 : VOIS2(2,2)=GR2(2,2) 159 : VOIS2(2,3)=GR2(2,3) 160 : VOIS2(3,1)=GR2(3,1) 161 : VOIS2(3,2)=GR2(3,2) 162 : VOIS2(3,3)=GR2(3,3) 163 : VOIS2(4,1)=GR2(4,1) 164 : VOIS2(4,2)=GR2(4,2) 165 : VOIS2(4,3)=GR2(4,3) 166 : C 167 : RETURN 168 : END 169 : 170 : 171 :
© Cast3M 2003 - All rights reserved.
Disclaimer