1 : C ELCHPO SOURCE CHAT 06/03/29 21:19:58 5360 2 : 3 : C======================================================================= 4 : c fonction: 5 : c sous routine pour arranger un chpo qui a souffert apres elim 6 : c 7 : c arguments: 8 : c ip1 (e/s) pointeur sur le champ par point 9 : c 10 : c variables: 11 : c * mtrav : - bb(i,j) est la valeur de la ieme inconnue de champ pour 12 : c le jieme noeud du tableau igeo . 13 : c - inco(nnin) contient le nom des nnin inconnues differentes 14 : c - ibin(i,j)=1 ou 0 indique que la ieme inconnue du champ 15 : c existe pour le jieme noeud du tableau igeo . 16 : c - igeo(i) est le numero a mettre dans un objet meleme pour 17 : c referencer le ieme noeud . 18 : c 19 : C= A. DE GAYFFIER, le 7 juillet 1994. = 20 : C======================================================================= 21 : 22 : SUBROUTINE ELCHPO(IP1,iratt) 23 : 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : 27 : -INC CCOPTIO 28 : -INC SMCHPOI 29 : -INC SMELEME 30 : -INC SMCOORD 31 : -INC TMTRAV 32 : 33 : SEGMENT MTR1 34 : CHARACTER*4 TINCO(NNIN) 35 : ENDSEGMENT 36 : SEGMENT MTR2 37 : INTEGER TIBIN(NNIN,NNNOE) 38 : REAL*8 TBB(NNIN,NNNOE) 39 : ENDSEGMENT 40 : SEGMENT MTR3 41 : INTEGER TGEO(0) 42 : ENDSEGMENT 43 : SEGMENT MTR4 44 : INTEGER THARM(0) 45 : ENDSEGMENT 46 : SEGMENT MTR5 47 : INTEGER ICO(NC) 48 : ENDSEGMENT 49 : SEGMENT MTR6 50 : INTEGER INO(NOE) 51 : ENDSEGMENT 52 : 53 : PARAMETER (Epsi=1.D-30) 54 : CHARACTER*4 cmot 55 : LOGICAL FLAG 56 : 57 : MCHPOI=IP1 58 : SEGACT,MCHPOI 59 : 60 : C verification de la compatibilite des natures 61 : NAT=JATTRI(/1) 62 : NATU=NAT 63 : IF (NATU.GT.0) THEN 64 : NATU=JATTRI(1) 65 : ENDIF 66 : C la nature est indeterminee on ne peut rien faire 67 : IF (NATU.EQ.0) THEN 68 : Iratt=2 69 : SEGDES,MCHPOI 70 : RETURN 71 : ENDIF 72 : 73 : c on eclate le champ par point dans le segment mtrav 74 : NNIN=0 75 : NNNOE=0 76 : SEGINI,MTR1,MTR2,MTR3,MTR4 77 : 78 : c boucle sur les msoupo 79 : c 80 : DO 60 i=1,IPCHP(/1) 81 : MSOUPO=IPCHP(i) 82 : SEGACT,MSOUPO 83 : MPOVAL=IPOVAL 84 : IF (MPOVAL.EQ.0) THEN 85 : SEGSUP,MTR1,MTR2,MTR3,MTR4 86 : SEGDES,MSOUPO,MCHPOI 87 : RETURN 88 : ENDIF 89 : c 90 : c boucle sur les composantes 91 : c on remplit tinco avec le nom des composantes 92 : NC=NOCOMP(/2) 93 : SEGINI,MTR5 94 : DO 20 j=1,NC 95 : cmot=NOCOMP(j) 96 : DO k=1,NNIN 97 : IF (TINCO(k).EQ.cmot) THEN 98 : ICO(j)=k 99 : GOTO 20 100 : ENDIF 101 : ENDDO 102 : c il y une inconnue de plus dans tinco 103 : NNIN=NNIN+1 104 : ICO(j)=NNIN 105 : SEGADJ,MTR1 106 : TINCO(NNIN)=cmot 107 : THARM(**)=NOHARM(j) 108 : 20 CONTINUE 109 : c 110 : c boucle sur les noeuds du msoupo 111 : MELEME=IGEOC 112 : SEGACT,MELEME 113 : NOE=NUM(/2) 114 : SEGINI,MTR6 115 : DO 40 j=1,NOE 116 : c boucle sur les noeuds du tableau geo 117 : c pour savoir si le noeud j appartient a geo 118 : jnoe=NUM(1,j) 119 : DO k=1,NNNOE 120 : IF (TGEO(k).EQ.jnoe) THEN 121 : INO(j)=k 122 : GOTO 40 123 : ENDIF 124 : ENDDO 125 : c le noeud n'etait pas dans la pile 126 : NNNOE=NNNOE+1 127 : INO(j)=NNNOE 128 : TGEO(**)=jnoe 129 : 40 CONTINUE 130 : c 131 : c encore une boucle sur les noeuds pour remplir tbb avec les valeurs 132 : c ico et ino servent pour retrouver les numeros dans tgeo et tinco 133 : SEGADJ,MTR2 134 : SEGACT,MPOVAL 135 : DO k=1,NC 136 : FLAG=.TRUE. 137 : icok=ICO(k) 138 : DO j=1,NUM(/2) 139 : c il s'agit d'un point double 140 : inoj=INO(j) 141 : IF (TIBIN(icok,inoj).NE.0) THEN 142 : IF (NATU.EQ.2) THEN 143 : c le champ est discret on additionne 144 : TBB(icok,inoj)=TBB(icok,inoj)+VPOCHA(j,k) 145 : ELSE 146 : c le champ est diffus il faut l'egalite 147 : V1=TBB(icok,inoj) 148 : V2=VPOCHA(j,k) 149 : VMOY=0.5*(V1+V2)+Epsi 150 : c test sur la difference relative 151 : c on commence par chercher un ordre de grandeur de la 152 : c composante sur la sous zone pour faire un test sur la 153 : c valeur absolue de la difference 154 : IF (ABS(V2-V1).GT.(1.D-4*ABS(VMOY))) THEN 155 : IF (FLAG) THEN 156 : THEMAX=0. 157 : DO l=1,NUM(/2) 158 : THEMAX=MAX(ABS(VPOCHA(l,k)),THEMAX) 159 : ENDDO 160 : FLAG=.FALSE. 161 : ENDIF 162 : c il n'y a pas egalite : erreur 163 : IF (ABS(V2-V1).GT.(1.D-4*THEMAX)) THEN 164 : Iratt=2 165 : c les lignes suivantes sont en commentaire de facon 166 : c a traiter quand meme les champ par point diffus dont les 167 : c valeurs sont distinctes: on prend la moyenne 168 : c SEGDES,MPOVAL,MSOUPO,MELEME 169 : c SEGSUP,mtr1,mtr2,mtr3,mtr4,mtr5,mtr6 170 : c RETURN 171 : ENDIF 172 : ENDIF 173 : c on affecte la valeur moyenne dans tous les cas 174 : TBB(icok,inoj)=VMOY 175 : ENDIF 176 : ELSE 177 : TBB(icok,inoj)=VPOCHA(j,k) 178 : TIBIN(icok,inoj)=1 179 : ENDIF 180 : ENDDO 181 : ENDDO 182 : SEGDES,MPOVAL 183 : SEGDES,MELEME 184 : SEGSUP,MTR5,MTR6 185 : SEGDES,MSOUPO 186 : 60 CONTINUE 187 : 188 : C= Remplissage du segment MTRAV (ITRAV) 189 : SEGINI,MTRAV 190 : DO i=1,NNIN 191 : INCO(i)=TINCO(i) 192 : C*OF NHAR(i)=THARM(i) 193 : ENDDO 194 : C*OF IF temporaire en attendant operateur remplacant procedure creer_3D 195 : IF (IFOMOD.EQ.1) THEN 196 : DO i=1,NNIN 197 : NHAR(i)=THARM(i) 198 : ENDDO 199 : ENDIF 200 : DO j=1,NNNOE 201 : IGEO(j)=TGEO(j) 202 : DO i=1,NNIN 203 : BB(i,j)=TBB(i,j) 204 : IBIN(i,j)=TIBIN(i,j) 205 : ENDDO 206 : ENDDO 207 : ITRAV=MTRAV 208 : 209 : c reconstuction de la partition 209 : CALL CRECHP(ITRAV,ICHP) 210 : c on ajuste le contenu du chapeau 211 : MCHPO1=ICHP 212 : SEGACT,MCHPO1 213 : NSOUPO=MCHPO1.IPCHP(/1) 214 : SEGADJ,MCHPOI 215 : DO i=1,NSOUPO 216 : IPCHP(i)=MCHPO1.IPCHP(i) 217 : ENDDO 218 : SEGDES,MCHPOI 219 : 220 : SEGSUP,MCHPO1 221 : SEGSUP,MTR1,MTR2,MTR3,MTR4,MTRAV 222 : 223 : RETURN 224 : END 225 : 226 : 227 : 228 :
© Cast3M 2003 - All rights reserved.
Disclaimer