1 : C VARCHE SOURCE PV 09/03/12 21:36:12 6325 2 : SUBROUTINE VARCHE(IPCHE1,IPEVOL,IPCHMU,IRET) 3 : *___________________________________________________________________ 4 : * 5 : * MULTIPLICATION D'UN MCHAML PAR UN OBJET EVOLUTION 6 : * (APPELE PAR OPERMU) 7 : * 8 : * ENTREES : 9 : * _________ 10 : * 11 : * IPCHE1 POINTEUR SUR UN CHAMELEM (TYPE MCHAML) 12 : * IPEVOL POINTEUR SUR UN OBJET EVOLUTION 13 : * 14 : * 15 : * SORTIE : 16 : * ________ 17 : * 18 : * IPCHMU POINTEUR SUR UN CHAMELEM RESULTAT (TYPE MCHAML) 19 : * IRET =0 SI L'OPERATION EST IMPOSSIBLE. 20 : * 21 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90 22 : * 23 : *___________________________________________________________________ 24 : * 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8(A-H,O-Z) 27 : * 28 : -INC CCOPTIO 29 : -INC SMCHAML 30 : -INC SMLREEL 31 : -INC SMEVOLL 32 : -INC SMCOORD 33 : * 34 : IRET=1 35 : KERRE=0 36 : YTT1=0.D0 37 : * 38 : * ON RECUPERE L'OBJET EVOLUTION 39 : * 40 : MEVOLL=IPEVOL 41 : SEGACT MEVOLL 42 : KEVOLL=IEVOLL(1) 43 : SEGACT KEVOLL 44 : MLREEL=IPROGX 45 : MLREE1=IPROGY 46 : SEGDES KEVOLL,MEVOLL 47 : SEGACT MLREEL,MLREE1 48 : NBPOIX=PROG(/1) 49 : NBPOIY=MLREE1.PROG(/1) 50 : * 51 : * ACTIVATION DU CHAMELEM 52 : * 53 : MCHELM=IPCHE1 54 : SEGINI,MCHEL1=MCHELM 55 : IPCHMU=MCHEL1 56 : * 57 : * BOUCLE SUR LES SOUS ZONE 58 : * 59 : DO 100 ISOUS=1,MCHEL1.ICHAML(/1) 60 : MCHAML=MCHEL1.ICHAML(ISOUS) 61 : SEGINI,MCHAM1=MCHAML 62 : MCHEL1.ICHAML(ISOUS)=MCHAM1 63 : * 64 : DO 200 ICOMP=1,MCHAM1.IELVAL(/1) 65 : MELVAL=MCHAM1.IELVAL(ICOMP) 66 : SEGINI,MELVA1=MELVAL 67 : N1PTEL=MELVA1.VELCHE(/1) 68 : IF (N1PTEL.EQ.0) THEN 69 : N2PTEL=MELVA1.IELCHE(/1) 70 : N2EL =MELVA1.IELCHE(/2) 71 : IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 72 : DO 201 IGAU=1,N2PTEL 73 : DO 201 IB=1,N2EL 74 : MLREE2=MELVA1.IELCHE(IGAU,IB) 75 : SEGACT MLREE2 76 : JG=MLREE2.PROG(/1) 77 : SEGINI MLREE3 78 : DO 202 IPROG=1,JG 79 : XTT1=MLREE2.PROG(IPROG) 79 : CALL VARIFO(MLREEL.PROG,MLREE1.PROG,NBPOIX,XTT1,YTT1,KERRE) 80 : IF (KERRE.EQ.211) THEN 80 : CALL ERREUR (211) 81 : SEGDES MLREEL,MLREE1,MLREE2 82 : SEGSUP MELVA1,MCHAM1,MCHEL1 83 : IRET=0 84 : RETURN 85 : ENDIF 86 : MLREE3.PROG(IPROG)=YTT1 87 : 202 CONTINUE 88 : MELVA1.IELCHE(IGAU,IB)=MLREE3 89 : SEGDES MLREE3,MLREE2 90 : 201 CONTINUE 91 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN 92 : DO 203 IGAU=1,N2PTEL 93 : DO 203 IB=1,N2EL 94 : IP=MELVA1.IELCHE(IGAU,IB) 95 : IREF=(IP-1)*(IDIM+1) 96 : * 97 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 98 : * 99 : SEGACT MCOORD 100 : NBNO=XCOOR(/1)/(IDIM+1) 101 : NBNOI=NBNO 102 : NBPTS=NBNO+1 103 : SEGADJ MCOORD 104 : * 105 : DO 204 IC=1,IDIM 106 : XTT1=XCOOR(IREF+IC) 106 : CALL VARIFO(MLREEL.PROG,MLREE1.PROG,NBPOIX,XTT1,YTT1,KERRE) 107 : IF (KERRE.EQ.211) THEN 107 : CALL ERREUR (211) 108 : SEGDES MLREEL,MLREE1,MLREE2 109 : SEGSUP MELVA1,MCHAM1,MCHEL1 110 : IRET=0 111 : RETURN 112 : ENDIF 113 : XCOOR(NBNOI*(IDIM+1)+IC)=XTT1*YTT1 114 : 204 CONTINUE 115 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 116 : IELCHE(IGAU,IB)=NBPTS 117 : 203 CONTINUE 118 : 119 : ELSE 120 : * 121 : * NOM DE COMPOSANTE NON RECONNU 122 : * 123 : MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) 123 : CALL ERREUR (197) 124 : SEGSUP MELVA1,MCHAM1,MCHEL1 125 : RETURN 126 : ENDIF 127 : ELSE 128 : N1EL=MELVA1.VELCHE(/2) 129 : DO 300 IGAU=1,N1PTEL 130 : DO 300 IB=1,N1EL 131 : XTT1 = MELVA1.VELCHE(IGAU,IB) 131 : CALL VARIFO(MLREEL.PROG,MLREE1.PROG,NBPOIX,XTT1,YTT1,KERRE) 132 : IF(KERRE.EQ.211)THEN 132 : CALL ERREUR (211) 133 : SEGDES MLREEL,MLREE1 134 : SEGSUP MELVA1,MCHAM1,MCHEL1 135 : IRET=0 136 : ENDIF 137 : MELVA1.VELCHE(IGAU,IB)=YTT1 138 : 300 CONTINUE 139 : ENDIF 140 : MCHAM1.IELVAL(ICOMP)=MELVA1 141 : SEGDES MELVA1 142 : 200 CONTINUE 143 : SEGDES MCHAM1 144 : 100 CONTINUE 145 : SEGDES MCHEL1 146 : * 147 : SEGDES MLREEL,MLREE1 148 : RETURN 149 : END 150 : 151 : 152 :
© Cast3M 2003 - All rights reserved.
Disclaimer