1 : C RAFF2D SOURCE CHAT 11/03/16 21:30:02 6902 2 : SUBROUTINE RAFF2D(IPT2,ICPR,KARPOS,KARETE,KMILIE,MELVA2,NACREE, 3 : .KARAF,IPT4,IDCP,IPT5,KARET2) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : IMPLICIT INTEGER(I-N) 6 : -INC CCOPTIO 7 : -INC SMCOORD 8 : -INC CCGEOME 9 : -INC SMELEME 10 : -INC SMCHPOI 11 : -INC SMMODEL 12 : -INC SMCHAML 13 : C 14 : C======================================================================= 15 : C Initialisations - Declarations 16 : C======================================================================= 17 : SEGMENT ICPR((XCOOR(/1)/(IDIM+1)),2) 18 : SEGMENT KARETE(NBNDS,NCOL) 19 : SEGMENT KARET2(NBNDS,NCOL) 20 : SEGMENT KMILIE(NBNDS,NCOL) 21 : SEGMENT KARPOS(NBNDS) 22 : SEGMENT NUMNOE(INUMNO) 23 : SEGACT IPT2,ICPR,KARPOS,KARETE,KMILIE*MOD,MELVA2,KARET2 24 : NBNN=NBNNE(LNELM(2,(IPT2.ITYPEL-1)*2+1)) 25 : INELM=LNELM(1,(IPT2.ITYPEL-1)*2+1) 26 : C 27 : C======================================================================= 28 : C Phase de raffinement 2D 29 : C======================================================================= 30 : C 31 : C 1/ Creation du squelette du maillage resultat 32 : NBELEM=IPT2.NUM(/2)-KARAF+INELM*KARAF 33 : NBSOUS=0 34 : NBREF=0 35 : SEGINI IPT4 36 : IPT4.ITYPEL=LNELM(2,(IPT2.ITYPEL-1)*2+1) 37 : LPO2=LPOS2(IPT2.ITYPEL) 38 : NBPT1=XCOOR(/1)/(IDIM+1) 39 : NBPTS=NBPT1+NACREE+KARAF*NBINTE(IPT2.ITYPEL) 40 : SEGADJ MCOORD 41 : INUMNO=NBRAF(IPT2.ITYPEL) 42 : SEGINI NUMNOE 43 : LCOMP=1 44 : C 45 : C 2/ Recherche des elements a raffiner 46 : DO 6 IARAF=1,MELVA2.VELCHE(/2) 47 : IF (MELVA2.VELCHE(1,IARAF).NE.1) THEN 48 : DO 1 IJKL=1,IPT2.NUM(/1) 49 : IPT4.NUM(IJKL,NBELEM)=IPT2.NUM(IJKL,IARAF) 50 : 1 CONTINUE 51 : NBELEM=NBELEM-1 52 : GOTO 6 53 : ENDIF 54 : C 55 : C 3/ Raffinement de l'element 56 : JCOMPT=0 57 : JPOS5=LPOS5(IPT2.ITYPEL) 58 : DO 4 I=1,NBRAF(IPT2.ITYPEL) 59 : JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) 60 : JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) 61 : JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT 62 : LTYPNO=JTYPNO(JPOS5-1+I) 63 : IF (LTYPNO.EQ.0) THEN 64 : NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) 65 : NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) 66 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 67 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 68 : DO 2 K=1,MAX(1,KARPOS(NMIN)) 69 : IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 70 : 2 CONTINUE 71 : IF (KMILIE(NMIN,NEXIST).GT.0) THEN 72 : NUMNOE(I)=KMILIE(NMIN,NEXIST) 73 : KMILIE(NMIN,NEXIST)=0 74 : JCOMPT=JCOMPT+JLONG 75 : GOTO 4 76 : ELSE 77 : NBPT1=NBPT1+1 78 : NUMNOE(I)=NBPT1 79 : KMILIE(NMIN,NEXIST)=NBPT1 80 : ENDIF 81 : ELSEIF (LTYPNO.EQ.7) THEN 82 : NBPT1=NBPT1+1 83 : NUMNOE(I)=NBPT1 84 : ELSE 85 : WRITE(*,*) 'ERREUR, on ne devrait jamais passer ici !' 86 : ENDIF 87 : C 88 : C 4/ Creation des nouveaux points 89 : XPT=0. 90 : YPT=0. 91 : DO 3 J=1,JLONG 92 : NGLOB=IPT2.NUM(LISNOE(JLISN-1+J),IARAF) 93 : XINI=XCOOR((NGLOB-1)*(IDIM+1)+1) 94 : YINI=XCOOR((NGLOB-1)*(IDIM+1)+2) 95 : XPT=XPT+XINI*XCOEFF(JPOS1-1+J) 96 : YPT=YPT+YINI*XCOEFF(JPOS1-1+J) 97 : 3 CONTINUE 98 : XCOOR((NBPT1-1)*(IDIM+1)+1)=XPT 99 : XCOOR((NBPT1-1)*(IDIM+1)+2)=YPT 100 : JCOMPT=JCOMPT+JLONG 101 : 4 CONTINUE 102 : JPOS4=LPOS4(IPT2.ITYPEL) 103 : C 104 : C 5/ Creation des nouveaux elements 105 : C On remplit la portion de IPT4 relative aux elements crees a partir 106 : C de la division de l'element IARAF (indice de boucle 1). 107 : C Cette portion de IPT4 contient les colonnes dont la valeur s'etend 108 : C de INELM*(LCOMP-1)+1 a INELM*LCOMP. 109 : DO 5 J=1,INELM 110 : DO 5 I=1,IPT4.NUM(/1) 111 : NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I) 112 : IF (NTEMP.GT.NBNN) THEN 113 : IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN) 114 : ELSE 115 : IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF) 116 : ENDIF 117 : 5 CONTINUE 118 : LCOMP=LCOMP+1 119 : 6 CONTINUE 120 : C 121 : C======================================================================= 122 : C Preparation du maillage de relations 123 : C======================================================================= 124 : C On cree un maillage IPT5 contenant tous les noeuds soumis a des 125 : C relations 126 : C 127 : C 1/ Comptage du nombre de noeuds soumis a des relations 128 : NBELEM=0 129 : DO 7 J=1,KMILIE(/2) 130 : DO 7 I=1,KMILIE(/1) 131 : IF (KARET2(I,J).NE.2) GOTO 7 132 : IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1 133 : 7 CONTINUE 134 : C 135 : C 2/ Creation de IPT5 136 : IPT5=0 137 : IF (NBELEM.EQ.0) GOTO 999 138 : NBNN=5 139 : NBREF=0 140 : NBSOUS=0 141 : SEGINI IPT5 142 : IPT5.ITYPEL=48 143 : C 144 : C 3/ Renseignement des noeuds support des relations 145 : DO 8 J=1,KMILIE(/2) 146 : DO 8 I=1,KMILIE(/1) 147 : IF (KARET2(I,J).NE.2) GOTO 8 148 : IF (KMILIE(I,J).GT.0) THEN 149 : NBREF=NBREF+1 150 : IPT5.NUM(1,NBREF)=KMILIE(I,J) 151 : ENDIF 152 : 8 CONTINUE 153 : C 154 : C 4/ Recherche des noeuds formant les relations 155 : DO 14 IARAF=1,MELVA2.VELCHE(/2) 156 : IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 14 157 : JCOMPT=0 158 : JPOS5=LPOS5(IPT2.ITYPEL) 159 : DO 13 I=1,NBRAF(IPT2.ITYPEL) 160 : JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) 161 : JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) 162 : JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT 163 : LTYPNO=JTYPNO(JPOS5-1+I) 164 : IF (LTYPNO.NE.0) GOTO 12 165 : NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) 166 : NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) 167 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 168 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 169 : DO 9 K=1,MAX(1,KARPOS(NMIN)) 170 : IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 171 : 9 CONTINUE 172 : IF (KARET2(NMIN,NEXIST).NE.2) GOTO 12 173 : IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 12 174 : NEXIS5=0 175 : DO 10 MM=1,IPT5.NUM(/2) 176 : INOEGL=KMILIE(NMIN,NEXIST) 177 : INRELA=IPT5.NUM(1,MM) 178 : IF (INOEGL.EQ.INRELA) NEXIS5=MM 179 : 10 CONTINUE 180 : C 181 : C 5/ Renseignement des noeuds formant les relations 182 : DO 11 IHH=1,JLONG 183 : IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF) 184 : 11 CONTINUE 185 : IF (JLONG.EQ.2) IPT5.NUM(5,NEXIS5)=1 186 : IF (JLONG.EQ.3) IPT5.NUM(5,NEXIS5)=2 187 : 12 CONTINUE 188 : JCOMPT=JCOMPT+JLONG 189 : 13 CONTINUE 190 : 14 CONTINUE 191 : C 192 : C======================================================================= 193 : C Fin du programme 194 : C======================================================================= 195 : 999 CONTINUE 196 : RETURN 197 : END 198 : 199 : 200 : 201 : 202 :
© Cast3M 2003 - All rights reserved.
Disclaimer