1 : C MANUC7 SOURCE FANDEUR 13/01/29 21:16:00 7683 2 : SUBROUTINE MANUC7(IPMODL,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2, 3 : . LETYP,JER1,ISUP1,ICHA,itart) 4 : *------------------------------------------------------------------ 5 : * 6 : * CREATION D'UN MCHAML 7 : * 8 : *------------------------------------------------------------------ 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : -INC SMCHAML 12 : -INC SMELEME 13 : -INC SMLMOTS 14 : -INC SMLREEL 15 : -INC SMLENTI 16 : -INC SMMODEL 17 : -INC SMINTE 18 : -INC CCOPTIO 19 : -INC CCGEOME 20 : * 21 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 22 : * ----------- 23 : * 24 : * MLENT1 (E) POINTEURS SUR ZONES ELEMENTAIRES DE MAILLAGE 25 : * MLMOTS (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS 26 : * MLMOT3 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES 27 : * MLMOT2 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES 28 : * DES CONSTITUANTS 29 : * IPOI (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL 30 : * MONMOT (E) MOT DE 8 CARACTERES 31 : * LETYP (E) TYPE DU MCHAML A CREER 32 : * JER1 (E) LONGUEUR DE LA CHAINE DE CARACTERES 33 : * IPMODL (E) POINTEUR DE L'OBJET MODELE 34 : * ISUP1 (E) SUPPORT DEMANDE 35 : * ICHA (S) POINTEUR SUR LE MCHAML RESULTAT 36 : * 37 : * LANGAGE: 38 : * -------- 39 : * 40 : * ESOPE + FORTRAN77 41 : * 42 : ************************************************************************ 43 : * 44 : SEGMENT MPTVAL 45 : INTEGER IPOS(NS) ,NSOF(NS) 46 : INTEGER IVAL(NCOSOU) 47 : CHARACTER*16 TYVAL(NCOSOU) 48 : ENDSEGMENT 49 : * 50 : SEGMENT NOTYPE 51 : CHARACTER*16 TYPE(NBTYPE) 52 : ENDSEGMENT 53 : * 54 : SEGMENT INFO 55 : INTEGER INFELL(JG) 56 : ENDSEGMENT 57 : * 58 : PARAMETER ( N3=6 ) 59 : PARAMETER (NINF=3) 60 : 61 : CHARACTER*(*) MONMOT, LETYP 62 : 63 : CHARACTER*8 CHARIN,chaiii 64 : CHARACTER*(NCONCH) CONM 65 : CHARACTER*16 typppp 66 : CHARACTER*4 CAR,CAR2 67 : DIMENSION INFOS(NINF) 68 : C 69 : C ACTIVATION DU MODELE 70 : C 71 : MMODEL=IPMODL 72 : SEGACT MMODEL 73 : NSOUS=KMODEL(/1) 74 : KEL22 = 0 75 : DO I=1,NSOUS 76 : IMODEL=KMODEL(I) 77 : SEGACT IMODEL*NOMOD 78 : IF (NEFMOD.EQ.22) KEL22 = KEL22+1 79 : ENDDO 80 : 81 : INFOS(1) = 0 82 : INFOS(2) = 0 83 : INFOS(3) = NIFOUR 84 : INFO = 0 85 : * 86 : * INITIALISATION DU SEGMENT MCHELM 87 : * 88 : N1 = NSOUS-KEL22 89 : L1=JER1 90 : SEGINI,MCHELM 91 : ICHA=MCHELM 92 : TITCHE=LETYP 93 : IFOCHE=IFOUR 94 : * 95 : SEGACT,MLMOTS 96 : SEGACT,MLMOT3 97 : SEGACT,MLMOT2 98 : N2=MOTS(/2) 99 : IF(MONMOT.EQ.'REAL*8 ') THEN 100 : MLREEL=IPOI 101 : SEGACT,MLREEL 102 : ELSE 103 : MLENTI=IPOI 104 : SEGACT,MLENTI 105 : ENDIF 106 : * 107 : * BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE 108 : * 109 : kch=0 110 : DO 20 I=1,NSOUS 111 : C 112 : C ON RECUPERE L INFORMATION GENERALE 113 : C 114 : IMODEL=KMODEL(I) 115 : C* SEGACT IMODEL*NOMOD 116 : IPMAIL=IMAMOD 117 : CONM =CONMOD 118 : C____________________________________________________________________ 119 : C 120 : C INFORMATION SUR L'ELEMENT FINI 121 : C____________________________________________________________________ 122 : C 123 : MELE=NEFMOD 124 : IF (MELE.EQ.22) GOTO 20 125 : kch=kch+1 126 : * 127 : ISUP = ISUP1 128 : IPPORE=0 129 : IF(MELE.GE.79.AND.MELE.LE.83) IPORE=NBNNE(NUMGEO(MELE)) 130 : NFOR=FORMOD(/2) 130 : CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE') 130 : CALL PLACE(FORMOD,NFOR,ICONV,'CONVECTION') 130 : CALL PLACE(FORMOD,NFOR,IFROT,'FROTTEMENT') 130 : CALL PLACE(FORMOD,NFOR,IDARC,'DARCY') 131 : C 132 : C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET 133 : IF(IDARC.NE.0)THEN 133 : CALL LEKMOD(MMODEL,IPTABL,INEFMD) 134 : CHARIN = 'MAILLAGE' 134 : CALL LEKTAB(IPTABL,CHARIN, IOBRE) 135 : IF (IERR.NE.0) RETURN 136 : IPT1 = IOBRE 137 : IPMAIL= IOBRE 138 : SEGACT MMODEL,IMODEL 139 : DO 30 JJ=1,N1 140 : IMODE1=KMODEL(JJ) 141 : SEGACT IMODE1 142 : 30 CONTINUE 143 : IF(N1.GT.1)THEN 144 : SEGACT IPT1 145 : IPMAIL= IPT1.LISOUS(I) 146 : C SEGDES IPT1 147 : ENDIF 148 : ENDIF 149 : * 150 : * PETIT TEST EN CAS DE FORMULATION FROTTEMENT 151 : * LE SEUL SUPPORT = LES NOEUDS 152 : * AM 25/1/08 ON FORCE LE SUPPORT EN CONSEQUENCE 153 : * AU LIEU DE SORTIR EN ERREUR 154 : * 155 : IF(IFROT.NE.0.AND.ISUP.NE.1) ISUP = 1 156 : * 157 : IPMIN=0 158 : MFR=0 159 : IF(ISUP.NE.1)THEN 160 : segact imodel 161 : IF(ITHER.EQ.0.AND.ICONV.EQ.0) THEN 162 : if( 2+isup.gt.infmod(/1)) then 162 : CALL ELQUOI(MELE,0,ISUP,IPINF,IMODEL) 163 : IF (IERR.NE.0) GOTO 99 164 : INFO=IPINF 165 : IPMIN=INFELL(11) 166 : MFR=INFELL(13) 167 : else 168 : IPMIN=infmod(isup+2) 169 : MFR=INFELE(13) 170 : endif 171 : ELSE 172 : IF(ITHER.NE.0)THEN 173 : iplr=0 174 : iplc=0 174 : CALL PLACE(formod,nfor,iplr,'RAYONNEMENT') 174 : CALL PLACE(formod,nfor,iplc,'CONVECTION') 175 : if(iplr+iplc.eq.0) then 175 : CALL TSHAPE(MELE,'GAUSS',IPMIN) 176 : else 177 : NLG=NUMGEO(MELE) 177 : CALL TSHAPE(NLG,'GAUSS',IPMIN) 178 : endif 179 : ELSE 180 : NLG=NUMGEO(MELE) 180 : CALL TSHAPE(NLG,'GAUSS',IPMIN) 181 : ENDIF 182 : c en thermique, on veut les points de gauss ad hoc 183 : isup = 6 184 : ENDIF 185 : ENDIF 186 : MINTE=IPMIN 187 : IF (IPMIN.NE.0) SEGACT,MINTE 188 : IMACHE(kch)=IPMAIL 189 : CONCHE(kch)=CONMOD 190 : INFCHE(kch,1) = 0 191 : INFCHE(kch,2) = 0 192 : INFCHE(kch,3) = NIFOUR 193 : INFCHE(kch,4) = IPMIN 194 : INFCHE(kch,5) = 0 195 : INFCHE(kch,6) = ISUP 196 : SEGINI,MCHAML 197 : ICHAML(kch)=MCHAML 198 : * 199 : DO 10 IN=1,N2 200 : NOMCHE(IN)=MOTS(IN) 201 : IF (MONMOT.EQ.'REAL*8 ') THEN 202 : TYPCHE(IN)=MONMOT(1:6) 203 : N1PTEL=1 204 : N1EL=1 205 : N2PTEL=0 206 : N2EL=0 207 : ELSE 208 : CAR =MLMOT3.MOTS(IN) 209 : CAR2=MLMOT2.MOTS(IN) 210 : * 211 : * TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML' 212 : *--------------- 213 : IF (CAR.EQ.'MCHA') THEN 214 : IPT = LECT(IN) 215 : * 216 : * MODIF 02/94 POUR POUTRE A FIBRES 217 : * TEST SUR LES MAILLAGES POINTES 218 : * 219 : MCHEL1=IPT 220 : SEGACT MCHEL1 221 : NSOUS=MCHEL1.ICHAML(/1) 222 : IDEM=0 223 : DO 294 IFIB=1,NSOUS 224 : IF(IPMAIL.EQ.MCHEL1.IMACHE(IFIB)) IDEM=1 225 : 294 CONTINUE 226 : SEGDES MCHEL1 227 : * 228 : IF(IDEM.EQ.0) GO TO 295 229 : * 229 : CALL QUESUP(IPMODL,IPT,ISUP,0,IRET,IRET2) 230 : MMODEL=IPMODL 231 : SEGACT MMODEL 232 : DO 100 J=1,N1 233 : IMODE1=KMODEL(J) 234 : SEGACT IMODE1 235 : 100 CONTINUE 236 : IF (IRET.GT.1) THEN 237 : * IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) 238 : * & SEGSUP INFO 239 : SEGSUP MCHAML 240 : GOTO 99 241 : ENDIF 242 : NBROBL=1 243 : NBRFAC=0 244 : SEGINI NOMID 245 : MOTAUX=NOMID 246 : LESOBL(1)=NOMCHE(IN) 247 : NBTYPE=1 248 : SEGINI NOTYPE 249 : MOTYPE=NOTYPE 250 : TYPE(1)=' ' 250 : CALL KOMCHA(IPT,IPMAIL,CONM,MOTAUX,MOTYPE, 251 : $ 2,INFOS,3,IVAAUX) 252 : SEGSUP NOTYPE 253 : IF (IERR.NE.0)THEN 254 : * IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) 255 : * & SEGSUP INFO 256 : SEGSUP MCHAML 257 : GOTO 99 258 : ENDIF 259 : IF(IRET.EQ.1)THEN 259 : CALL VALCHE(IVAAUX,1,IPMIN,IPPORE) 260 : IF(IERR.NE.0)THEN 261 : MPTVAL=IVAAUX 262 : MELVA1=IVAL(1) 263 : SEGDES MELVA1 264 : SEGSUP MPTVAL 265 : SEGSUP MCHAML 266 : GOTO 99 267 : ENDIF 268 : ENDIF 269 : MPTVAL=IVAAUX 270 : TYPCHE(IN)=TYVAL(1) 271 : MELVA1 = IVAL(1) 272 : SEGINI,MELVAL=MELVA1 273 : IELVAL(IN) = MELVAL 274 : IF(IRET.EQ.1)THEN 275 : SEGSUP MELVA1 276 : ELSE 277 : SEGDES MELVA1 278 : ENDIF 279 : SEGSUP,MPTVAL 280 : SEGDES,MELVAL 281 : GO TO 10 282 : ENDIF 283 : * 284 : 295 CONTINUE 285 : if(itart.eq.1.and.car(1:4).eq.'LIST' 286 : $ .and.car2(1:4).eq.'REEL') then 287 : TYPCHE(IN)='REAL*8 ' 288 : ipt4=ipmail 289 : segact ipt4 290 : n1el=ipt4.num(/2) 291 : segdes ipt4 292 : n1ptel=1 293 : N2PTEL=0 294 : N2EL=0 295 : else 296 : chaiii='POINTEUR' 297 : typppp= chaiii//car//car2 298 : TYPCHE(IN)=typppp 299 : if(ITART.EQ.1.AND.car2(1:4).eq.'INT ') then 300 : ipt4=ipmail 301 : segact ipt4 302 : n2el=ipt4.num(/2) 303 : segdes ipt4 304 : N1PTEL=0 305 : N1EL=0 306 : N2PTEL=1 307 : else 308 : N1PTEL=0 309 : N1EL=0 310 : N2PTEL=1 311 : N2EL=1 312 : endif 313 : endif 314 : ENDIF 315 : * 316 : * INITIALISATION DU SEGMENT MELVAL 317 : * 318 : SEGINI,MELVAL 319 : IELVAL(IN)=MELVAL 320 : IF (MONMOT.EQ.'REAL*8 ') THEN 321 : VELCHE(N1PTEL,N1EL)=PROG(IN) 322 : ELSE 323 : if( itart.eq.1.and.car(1:4).eq.'LIST' 324 : $ .and.car2(1:4).eq.'REEL') then 325 : mlree2= lect(in) 326 : segact mlree2 327 : ia=0 328 : do iop=1,n1el 329 : ia=ia+1 330 : if(ia.gt.mlree2.prog(/1)) ia=1 331 : velche(n1ptel,iop)= mlree2.prog(ia) 332 : enddo 333 : segdes mlree2 334 : else if ( itart.eq.1 335 : $ .and.car2(1:4).eq.'INT ') then 336 : mlent2= lect(in) 337 : segact mlent2 338 : ia = 0 339 : do iop=1,n2el 340 : ia=ia+1 341 : if(ia.gt.mlent2.lect(/1)) ia=1 342 : ielche(n2ptel,iop)= mlent2.lect(ia) 343 : enddo 344 : segdes mlent2 345 : else 346 : IELCHE(N2PTEL,N2EL)=LECT(IN) 347 : endif 348 : ENDIF 349 : SEGDES,MELVAL 350 : 10 CONTINUE 351 : * END DO 352 : IF (IPMIN.NE.0) SEGDES,MINTE 353 : IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) SEGSUP INFO 354 : SEGDES,MCHAML 355 : 20 CONTINUE 356 : * END DO 357 : * 358 : 99 CONTINUE 359 : IF (MONMOT.EQ.'REAL*8 ') THEN 360 : SEGDES,MLREEL 361 : ELSE 362 : SEGDES,MLENTI 363 : ENDIF 364 : SEGDES,MLMOTS 365 : SEGDES,MLMOT3 366 : SEGDES,MLMOT2 367 : * 368 : IF(IERR.EQ.0)THEN 369 : SEGDES,MCHELM 370 : ELSE 371 : SEGSUP,MCHELM 372 : ENDIF 373 : * 374 : RETURN 375 : END 376 : 377 :
© Cast3M 2003 - All rights reserved.
Disclaimer