1 : C MUCHEL SOURCE PV 09/03/12 21:29:08 6325 2 : SUBROUTINE MUCHEL(IPCHE1,XFLOT,IPCHMU,IEPS) 3 : *_______________________________________________________________________ 4 : * 5 : * MULTIPLIE UN CHPS PAR ELMTS PAR XFLO SI IEPS=1 6 : * MULTIPLIE UN CHPS PAR ELMTS PAR 1/XFLO SI IEPS=-1 7 : * LE CHPS RESULTANT VOIT SON POINTEUR STOCKE DANS IRET 8 : * SI L OPERATION N EST PAS POSSIBLE IRET=0 9 : * PAR EXEMPLE SI IEPS=-1 ET XFLOT=0. 10 : * (APPELE PAR OPERMU) 11 : * 12 : * ENTREES : 13 : * --------- 14 : * 15 : * IPCHE1 POINTEUR SUR LE CHAMPS PAR ELEMENT 16 : * XFLOT SCALAIRE 17 : * IEPS = 1 SI MULTIPLICATION 18 : * -1 SI DIVISION 19 : * 20 : * SORTIES : 21 : * --------- 22 : * 23 : * IPCHMU POINTEUR SUR LE CHAMPS*XFLOT**IEPS 24 : * =0 SI OPERATION IMPOSSSIBLE 25 : * 26 : * CODE EBERSOLT JUIN 84 27 : * 28 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90 29 : * 30 : *_______________________________________________________________________ 31 : * 32 : IMPLICIT INTEGER(I-N) 33 : IMPLICIT REAL*8(A-H,O-Z) 34 : * 35 : -INC SMCHAML 36 : -INC CCOPTIO 37 : -INC SMCOORD 38 : -INC SMLREEL 39 : -INC SMEVOLL 40 : * 41 : IPCHMU=0 42 : * 43 : IF(IEPS.EQ.-1.AND.XFLOT.EQ.0.) GOTO 666 44 : * 45 : IF(IEPS.EQ.1) XFLOT1=XFLOT 46 : IF(IEPS.EQ.-1) XFLOT1=1.D0/XFLOT 47 : * 48 : MCHEL1=IPCHE1 49 : SEGACT MCHEL1 50 : SEGINI,MCHELM=MCHEL1 51 : SEGDES MCHEL1 52 : IPCHMU=MCHELM 53 : * 54 : DO 72 ISOUS=1,ICHAML(/1) 55 : MCHAM1=ICHAML(ISOUS) 56 : SEGACT MCHAM1 57 : SEGINI,MCHAML=MCHAM1 58 : SEGDES MCHAM1 59 : ICHAML(ISOUS)=MCHAML 60 : DO 73 ICOMP=1,IELVAL(/1) 61 : MELVA1=IELVAL(ICOMP) 62 : SEGACT MELVA1 63 : SEGINI,MELVAL=MELVA1 64 : SEGDES MELVA1 65 : IELVAL(ICOMP)=MELVAL 66 : N1PTEL=VELCHE(/1) 67 : IF (N1PTEL.NE.0) THEN 68 : N1EL =VELCHE(/2) 69 : DO 74 IGAU=1,N1PTEL 70 : DO 74 IB=1,N1EL 71 : VELCHE(IGAU,IB)=XFLOT1*VELCHE(IGAU,IB) 72 : 74 CONTINUE 73 : ELSE 74 : N2PTEL=IELCHE(/1) 75 : N2EL =IELCHE(/2) 76 : IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 77 : DO 64 IGAU=1,N2PTEL 78 : DO 64 IB=1,N2EL 79 : ILREE1=IELCHE(IGAU,IB) 79 : CALL MUFLIR(ILREE1,XFLOT1,ILREEL,1) 80 : IELCHE(IGAU,IB)=ILREEL 81 : 64 CONTINUE 82 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN 83 : DO 54 IGAU=1,N2PTEL 84 : DO 54 IB=1,N2EL 85 : IP=IELCHE(IGAU,IB) 86 : IREF=(IP-1)*(IDIM+1) 87 : * 88 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 89 : * 90 : SEGACT MCOORD 91 : NBNO=XCOOR(/1)/(IDIM+1) 92 : NBNOI=NBNO 93 : NBPTS=NBNO+1 94 : SEGADJ MCOORD 95 : * 96 : DO 55 IC=1,IDIM 97 : XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XFLOT1 98 : 55 CONTINUE 99 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 100 : IELCHE(IGAU,IB)=NBPTS 101 : 54 CONTINUE 102 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN 103 : DO 65 IGAU=1,N2PTEL 104 : DO 65 IB=1,N2EL 105 : IEVOL1=IELCHE(IGAU,IB) 105 : CALL MUFLEV(IEVOL1,XFLOT,IEVOL2,IEPS) 106 : IELCHE(IGAU,IB)=IEVOL2 107 : 65 CONTINUE 108 : ELSE 109 : * 110 : * NOM DE COMPOSANTE NON RECONNU 111 : * 112 : MOTERR(1:4)=NOMCHE(ICOMP) 112 : CALL ERREUR(197) 113 : SEGSUP MELVAL 114 : SEGSUP MCHAML 115 : SEGSUP MCHELM 116 : IPCHMU=0 117 : RETURN 118 : ENDIF 119 : ENDIF 120 : SEGDES MELVAL 121 : * 122 : 73 CONTINUE 123 : SEGDES MCHAML 124 : * 125 : 72 CONTINUE 126 : SEGDES MCHELM 127 : * 128 : 666 CONTINUE 129 : RETURN 130 : END 131 : 132 : 133 : 134 : 135 :
© Cast3M 2003 - All rights reserved.
Disclaimer