1 : C LISSAG SOURCE CHAT 05/01/13 01:23:56 5004 2 : SUBROUTINE LISSAG 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC SMELEME 7 : -INC SMLREEL 8 : -INC SMCHPOI 9 : -INC SMCOORD 10 : SEGMENT EDICON 11 : INTEGER KSTRT, KSTEP, NMIR, IS 12 : REAL*8 CROT , SROT , SYMFCT 13 : LOGICAL LREAL, LIMAG 14 : ENDSEGMENT 15 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 16 : SEGMENT IVOISI 17 : INTEGER IVOI(LL,MM),INB(MM) 18 : ENDSEGMENT 19 : SEGMENT ICOO 20 : REAL*8 X(MV),Y(MV),P(MV),WNODE(MV) 21 : INTEGER LISVO(MV) 22 : ENDSEGMENT 23 : SEGMENT IVAL 24 : REAL*8 VAL(XCOOR(/1)/(IDIM+1)) 25 : ENDSEGMENT 26 : SEGMENT ITRAVA 27 : REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50) 28 : REAL*8 AK(M50),UM(M50),RM(M50) 29 : INTEGER IL(M50) 30 : ENDSEGMENT 31 : CHARACTER*4 MCLE(3) 32 : DATA MCLE/'PLAN','AXIS','POID'/ 33 : IF (IDIM .NE. 2) THEN 33 : CALL ERREUR(19) 34 : RETURN 35 : ENDIF 36 : U=0 37 : UX=1 38 : UY=2 39 : UXX=3 40 : UXY=4 41 : UYY=5 41 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 42 : IF(IERR.NE.0) RETURN 42 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 43 : IF(IERR.NE.0) RETURN 43 : CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU) 44 : IF(IERR.NE.0) RETURN 44 : CALL LIRENT ( ITYPE,1,IRETOU) 45 : IF(IERR.NE.0) RETURN 45 : CALL LIRMOT ( MCLE,2,ICOOR,1) 46 : IF(IERR.NE.0) RETURN 46 : CALL LIRMOT( MCLE(3),1,IVAL,0) 47 : W1ST=1. 48 : W1ND=1. 49 : IF(IVAL.NE.0) THEN 49 : CALL LIRREE( W1ST,1,IRETOU) 50 : IF(IERR.NE.0) RETURN 50 : CALL LIRREE( W1ND,1,IRETOU) 51 : IF(IERR.NE.0) RETURN 52 : ENDIF 52 : CALL LIROBJ( 'POINT ', IPO,0,IRETOU) 53 : XORG=0.D0 54 : YORG=0.D0 55 : IF(IRETOU.NE.0) THEN 56 : XORG=XCOOR((IPO-1)*(IDIM+1) +1) 57 : YORG=XCOOR((IPO-1)*(IDIM+1) +1) 58 : ENDIF 59 : C 60 : C 61 : C MISE SOUS FORME D'ELEMENTS POINTS DU 2EME MAILLAGE. IL SERVIRA AU 62 : C CHPOINT RESULTAT 63 : C 64 : SEGACT IPT2 64 : CALL CHANGE(IPT2,1) 65 : C WRITE(6,FMT='( '' SORTIE DE CHANGE '')') 66 : C 67 : C IVOI(I,J)=K VEUT DIRE QUE LE IEME VOISIN DU NOEUD J A LENUMERO GLOBAL K 68 : C INB(J)= K VEUT DIRE QUE LE JEME POINT LOCAL A K VOISIN 69 : C 70 : SEGINI ICPR 71 : SEGACT IPT1 72 : MELEME = IPT1 73 : IF(ITYPEL.EQ.1) THEN 73 : CALL ERREUR(16) 74 : RETURN 75 : ENDIF 76 : LIS = MAX(IPT1.LISOUS(/1),1) 77 : MM = 0 78 : DO 2 L=1,LIS 79 : IF(IPT1.LISOUS(/1).NE.0) THEN 80 : MELEME=IPT1.LISOUS(L) 81 : SEGACT MELEME 82 : ENDIF 83 : NBEL= NUM(/2) 84 : NBP= NUM(/1) 85 : DO 3 I=1,NBEL 86 : DO 3 J=1,NBP 87 : IKI =NUM(J,I) 88 : IF(ICPR(IKI).NE.0) GO TO 3 89 : MM = MM + 1 90 : ICPR(IKI) = MM 91 : 3 CONTINUE 92 : IF(IPT1.LISOUS(/1).NE.0) THEN 93 : SEGDES MELEME 94 : ENDIF 95 : 2 CONTINUE 96 : 4 CONTINUE 97 : C INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS 98 : IV = NBP - 1 99 : LL= IV * 3 100 : SEGINI IVOISI 101 : MELEME = IPT1 102 : LIS=MAX(1,IPT1.LISOUS(/1)) 103 : DO 6 LI=1,LIS 104 : IF(IPT1.LISOUS(/1).NE.0) THEN 105 : MELEME=IPT1.LISOUS(LI) 106 : SEGACT MELEME 107 : ENDIF 108 : DO 7 I=1,NUM(/2) 109 : DO 8 J=1,NUM(/1)-1 110 : IGLO= NUM(J,I) 111 : ILO = ICPR(IGLO) 112 : DO 9 K = J+1,NUM(/1) 113 : IGLA= NUM(K,I) 114 : ILA = ICPR(IGLA) 115 : IF(INB(ILO).GT.0) THEN 116 : DO 10 L=1,INB(ILO) 117 : IF(IVOI(L,ILO).EQ.IGLA) GO TO 9 118 : 10 CONTINUE 119 : ENDIF 120 : INB(ILO)=INB(ILO)+1 121 : INB(ILA)=INB(ILA)+1 122 : IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN 123 : LL = LL + IV 124 : SEGADJ IVOISI 125 : ENDIF 126 : IVOI(INB(ILO),ILO)=IGLA 127 : IVOI(INB(ILA),ILA)=IGLO 128 : 9 CONTINUE 129 : 8 CONTINUE 130 : 7 CONTINUE 131 : IF(IPT1.LISOUS(/1).EQ.0) THEN 132 : SEGDES MELEME 133 : ENDIF 134 : 6 CONTINUE 135 : C WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27) 136 : C WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17) 137 : C DO 1234 KL=1,17 138 : C WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL)) 139 : C 1234 CONTINUE 140 : SEGINI EDICON 141 : C 142 : C 143 : C ON BOUCLE SUR LES POINTS DU 2EME MAILLAGE LES ETAPES SONT: 144 : C RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE 145 : C FABRICATION DE LA PREMIERE COUCHE DE VOISINS 146 : C FABRICATION DE LA DEUXIEME COUCHE DE VOISINS 147 : C FABRICATION DU TABLEAU CONTENANT LES COORDONNEES 148 : C FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP 149 : C APPEL DE LA FONCTION LISSAGE 150 : C REMPLISSAGE DU CHPOINT RESULTAT 151 : C FIN DE BOUCLE 152 : C 153 : C ECLATEMENT DU CHPOINT INITIAL 154 : C 155 : SEGACT MCHPOI 156 : NAT=JATTRI(/1) 156 : IF(IPCHP(/1).NE.1) CALL ERREUR (25) 157 : IF(IERR.NE.0) RETURN 158 : MSOUPO=IPCHP(1) 159 : SEGACT MSOUPO 160 : IPT3=IGEOC 161 : SEGACT IPT3 162 : MPOVAL=IPOVAL 163 : SEGINI IVAL 164 : SEGACT MPOVAL 165 : DO 19 I=1,IPT3.NUM(/2) 166 : IGLO=IPT3.NUM(1,I) 167 : VAL(IGLO)=VPOCHA(I,1) 168 : 19 CONTINUE 169 : SEGDES MPOVAL,IPT3 170 : C CREATION DU CHPOINT RESULTAT 171 : NSOUPO=1 172 : SEGINI MCHPO1 173 : DO 18 II=1,NAT 174 : MCHPO1.JATTRI(II)=JATTRI(II) 175 : 18 CONTINUE 176 : NC=7 177 : SEGINI MSOUPO 178 : MCHPO1.IPCHP(1)=MSOUPO 179 : MCHPO1.IFOPOI=IFOMOD 180 : SEGDES MCHPO1,MCHPOI 181 : NOCOMP(1)='A' 182 : NOCOMP(2)='BX' 183 : NOCOMP(3)='BY' 184 : NOCOMP(4)='BXX' 185 : NOCOMP(5)='BXY' 186 : NOCOMP(6)='BYX' 187 : NOCOMP(7)='BYY' 188 : NOHARM(1)=NIFOUR 189 : NOHARM(2)=NIFOUR 190 : NOHARM(3)=NIFOUR 191 : NOHARM(4)=NIFOUR 192 : NOHARM(5)=NIFOUR 193 : NOHARM(6)=NIFOUR 194 : NOHARM(7)=NIFOUR 195 : IGEOC=IPT2 196 : SEGACT IPT2 197 : N = IPT2.NUM(/2) 198 : SEGINI MPOVAL 199 : IPOVAL=MPOVAL 200 : SEGDES MSOUPO 201 : MV=50 202 : SEGINI ICOO 203 : M42 = 42 204 : M50 = 50 205 : M42 = 84 206 : M50 = 100 207 : SEGINI ITRAVA 208 : IDIM1=IDIM+1 209 : DO 20 I=1,IPT2.NUM(/2) 210 : IP=IPT2.NUM(1,I) 211 : DISMI=123456789.E+10 212 : XA= XCOOR((IP-1)*IDIM1+1) 213 : XB= XCOOR((IP-1)*IDIM1+2) 214 : XC=0.D0 215 : IPMIN=0 216 : IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3) 217 : DO 21 J=1,ICPR(/1) 218 : IF(ICPR(J).EQ.0) GO TO 21 219 : YA=XCOOR((J-1)*IDIM1 +1) 220 : YB=XCOOR((J-1)*IDIM1+2) 221 : YC=0.D0 222 : IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3) 223 : XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC) 224 : IF(XDI.LE.DISMI) THEN 225 : DISMI=XDI 226 : IPMIN=J 227 : ENDIF 228 : 21 CONTINUE 229 : C WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN 230 : ILOC=ICPR(IPMIN) 231 : INN=INB(ILOC) 232 : IF(INN.GT.LISVO(/1)) THEN 233 : MV=MV+50 234 : SEGSUP ICOO 235 : SEGINI ICOO 236 : ENDIF 237 : LISVO(1)=IPMIN 238 : DO 22 K=1,INN 239 : LISVO(K+1)=IVOI(K,ILOC) 240 : 22 CONTINUE 241 : IDE=INN+1 242 : DO 23 K=1,INN+1 243 : ILOA=ICPR(LISVO(K)) 244 : INV=INB(ILOA) 245 : DO 24 L=1,INV 246 : ICAND = IVOI(L,ILOA) 247 : DO 25 M=1,IDE 248 : IF(ICAND.EQ.LISVO(M) ) GO TO 24 249 : 25 CONTINUE 250 : IDE=IDE+1 251 : IF(IDE.GT.MV) THEN 252 : MV=MV+50 253 : SEGADJ ICOO 254 : ENDIF 255 : LISVO(IDE)=ICAND 256 : 24 CONTINUE 257 : 23 CONTINUE 258 : DO 26 K=1,IDE 259 : IGLO= LISVO(K) 260 : X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1) 261 : Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2) 262 : WNODE(K)=W1ND 263 : P(K)=VAL(IGLO) 264 : 26 CONTINUE 265 : DO 27 K=1,INN 266 : 27 WNODE(K) = W1ST 267 : C WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI), 268 : C $KJI=1,IDE) 269 : C WRITE(6,FMT= '('' WNODE '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE) 270 : C WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE) 271 : IBON=1 272 : C CALCUL DES PARAMETRES 273 : M42CA = 84 274 : M50CA = 100 275 : IF ( M42.GT.M42CA) THEN 276 : M42=M42CA 277 : IBON=0 278 : ENDIF 279 : IF(M50.GT.M50CA) THEN 280 : M50=M50CA 281 : IBON=0 282 : ENDIF 283 : IF(IBON.EQ.0) THEN 284 : SEGSUP ITRAVA 285 : SEGINI ITRAVA 286 : ENDIF 287 : C APPEL DE LA FONCTION LISSAGE EN SORTIE U,UX,UY,UXX,UXY,UYY SONT 288 : C LES RESULTATS 289 : C 290 : KFLAG= 2 291 : IF ( ICOOR.EQ.1) THEN 292 : C WRITE (ISORT,'(A)') ,'*********** CARTESIEN *************** ' 292 : CALL CARSYM (ITYPE,EDICON) 292 : CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE, 293 : *XORG,YORG,IDE,EDICON,ICOO,ITRAVA) 294 : V1= U 295 : V2= UY 296 : V3= - UX 297 : IF (KFLAG.GT. 1) THEN 298 : V4 = UXY 299 : V5 = UYY 300 : V6 = - UXX 301 : V7 = - UXY 302 : END IF 303 : END IF 304 : IF ( ICOOR.EQ.2) THEN 305 : C WRITE (ISORT,'(A)') ,'*********** AXISYMETRIE*************** ' 305 : CALL CYLSYM (ITYPE,EDICON) 305 : CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE, 306 : *IDE,EDICON,ICOO,ITRAVA) 307 : V1 = U 308 : V2 = - UY 309 : V3 = UX 310 : IF (KFLAG.GT. 1) THEN 311 : V4 = - UXY 312 : V5 = - UYY 313 : V6 = UXX 314 : V7 = UXY 315 : END IF 316 : END IF 317 : C 318 : C 319 : C 320 : C 321 : C ON REMPLIT LES VALEURS 322 : C 323 : VPOCHA(I,1)=V1 324 : VPOCHA(I,2)=V2 325 : VPOCHA(I,3)=V3 326 : VPOCHA(I,4)=V4 327 : VPOCHA(I,5)=V5 328 : VPOCHA(I,6)=V6 329 : VPOCHA(I,7)=V7 330 : 20 CONTINUE 331 : SEGDES MPOVAL,IPT2 332 : SEGSUP ICPR,ICOO,IVOISI,IVAL 332 : CALL ECROBJ('CHPOINT ',MCHPO1) 333 : RETURN 334 : END 335 :
© Cast3M 2003 - All rights reserved.
Disclaimer