1 : C DEFO SOURCE CHAT 07/10/29 21:17:47 5940 2 : C CONSTRUCTION D'UN OBJET DE TYPE DEFORME A PARTIR D'UNE GEOMETRIE 3 : C D'UN CHPOIN UX UY UZ ET D'UN COEF D'AMPLIFICATION 4 : C 1995 Changement de defaut de couleur P.PEGON JRC-ISPRA 5 : C 6 : SUBROUTINE DEFO 7 : IMPLICIT INTEGER(I-N) 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC SMCHPOI 11 : -INC SMDEFOR 12 : -INC SMCOORD 13 : -INC SMELEME 14 : CHARACTER*4 NU(3),NV(3),NOC 15 : REAL*8 AMP,COMPMA 16 : DATA NU/'UX ','UY ','UZ '/ 17 : DATA NV/'UR ','UZ ','UT '/ 17 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 17 : CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU) 18 : C AMPLIFICATION 1 PAR DEFAUT 19 : AMP=1. 19 : CALL LIRREE(AMP,0,IRETOA) 20 : IF (IERR.NE.0) RETURN 21 : MTVE=0 21 : CALL LIROBJ('VECTEUR ',MTVE,0,IRETOU) 21 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 22 : IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 23 : ICOUL=ICOUL-1 24 : C VERIFICATION QU'IL Y A UX UY UZ PARMI LES INCONNUES DU CHPOINT 25 : SEGACT MCHPOI 26 : NSOUPO=IPCHP(/1) 27 : IRAT=1 28 : IF (NSOUPO.EQ.0) GOTO 13 29 : IRAT=1 30 : DO 10 ISOUPO=1,NSOUPO 31 : MSOUPO=IPCHP(ISOUPO) 32 : SEGACT MSOUPO 33 : NC=NOCOMP(/2) 34 : DO 11 I=1,NC 35 : NOC=NOCOMP(I) 36 : DO 12 J=1,IDIM 37 : IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN 38 : IF (NOC.EQ.NU(J)) IRAT=0 39 : ELSE 40 : IF (NOC.EQ.NV(J)) IRAT=0 41 : ENDIF 42 : 12 CONTINUE 43 : 11 CONTINUE 44 : SEGDES MSOUPO 45 : 10 CONTINUE 46 : SEGDES MCHPOI 46 : IF (IRAT.EQ.1) CALL ERREUR(184) 47 : 13 CONTINUE 48 : NDEF=1 49 : SEGINI MDEFOR 50 : AMPL(1)=AMP 51 : MTVECT(1)=MTVE 52 : IELDEF(1)=MELEME 53 : ICHDEF(1)=MCHPOI 54 : JCOUL(1)=ICOUL 54 : CALL ECROBJ('DEFORME ',MDEFOR) 55 : IF (IRETOA.EQ.1) GOTO 1000 56 : * CAS DE L'AMPLIFICATION AUTOMATIQUE ON MODIFIE L'OBJET 57 : * QU'ON VIENT D'ECRIRE. C'EST PAS BIEN | 58 : * CALCUL DU CADRE 59 : XGRAND=-1E30 60 : YGRAND=-1E30 61 : ZGRAND=-1E30 62 : XPETIT= 1E30 63 : YPETIT= 1E30 64 : ZPETIT= 1E30 65 : SEGACT MELEME 66 : NBSOUS=LISOUS(/1) 67 : IPT1=MELEME 68 : DO 50 ISOUS=1,MAX0(1,NBSOUS) 69 : IF (NBSOUS.NE.0) IPT1=LISOUS(ISOUS) 70 : SEGACT IPT1 71 : DO 55 I=1,IPT1.NUM(/1) 72 : DO 55 J=1,IPT1.NUM(/2) 73 : IPT=IPT1.NUM(I,J) 74 : IREF=(IDIM+1)*(IPT-1) 75 : XPT=XCOOR(IREF+1) 76 : XGRAND=MAX(XPT,XGRAND) 77 : XPETIT=MIN(XPT,XPETIT) 78 : YPT=XCOOR(IREF+2) 79 : YGRAND=MAX(YPT,YGRAND) 80 : YPETIT=MIN(YPT,YPETIT) 81 : ZPT=XCOOR(IREF+3) 82 : ZGRAND=MAX(ZPT,ZGRAND) 83 : ZPETIT=MIN(ZPT,ZPETIT) 84 : 55 CONTINUE 85 : IF (NBSOUS.EQ.0) GOTO 60 86 : SEGDES IPT1 87 : 50 CONTINUE 88 : SEGDES MELEME 89 : 60 CONTINUE 90 : CLONG=MAX(XGRAND-XPETIT,YGRAND-YPETIT,ZGRAND-ZPETIT) 91 : * ON VA ADMETTRE QUE LA DEFORME MAXIMALE EST CLONG/10 ??? 92 : COMPMA=0.D0 93 : * BOUCLE DANS LE CHAMP POINT 94 : SEGACT MCHPOI 95 : NSOUPO=IPCHP(/1) 96 : IF (NSOUPO.EQ.0) GOTO 113 97 : DO 100 ISOUPO=1,NSOUPO 98 : MSOUPO=IPCHP(ISOUPO) 99 : SEGACT MSOUPO 100 : MPOVAL=IPOVAL 101 : SEGACT MPOVAL 102 : NC=NOCOMP(/2) 103 : DO 110 I=1,NC 104 : NOC=NOCOMP(I) 105 : DO 120 J=1,IDIM 106 : IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN 107 : IF (NOC.EQ.NU(J)) GOTO 130 108 : ELSE 109 : IF (NOC.EQ.NV(J)) GOTO 130 110 : ENDIF 111 : GOTO 120 112 : 130 CONTINUE 113 : DO 140 K=1,VPOCHA(/1) 114 : COMPMA=MAX(COMPMA,ABS(VPOCHA(K,I))) 115 : 140 CONTINUE 116 : 120 CONTINUE 117 : 110 CONTINUE 118 : SEGDES MSOUPO,MPOVAL 119 : 100 CONTINUE 120 : SEGDES MCHPOI 121 : IF (COMPMA.EQ.0.D0) then 122 : ampl(1)=0 123 : ELSE 124 : AMPL(1)=CLONG/(10*COMPMA) 125 : endif 126 : 1000 CONTINUE 127 : * lecture eventuelle d'un champoint ou d'un chamelem + model 127 : CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU) 128 : if (iretou.ne.0) mdchp(1)=mchpoi 129 : if (iretou.eq.0) then 129 : CALL LIROBJ('MCHAML ',MCHEL,0,IRETOU) 130 : if (iretou.ne.0) then 130 : CALL LIROBJ('MMODEL ',MODEL,1,IRETOU) 131 : if(ierr.ne.0) return 132 : mdmode(1)=model 133 : * PASSER LES CHAMELEM AUX noeuds 133 : CALL CHASUP(MODEL,MCHEL,MCHAM,IRET,1) 134 : IF (IRET.NE.0) MCHAM=MCHEL 135 : mdchel(1)=mcham 136 : endif 137 : endif 138 : SEGDES MDEFOR 139 : RETURN 140 : 113 CONTINUE 140 : CALL ERREUR(475) 141 : RETURN 142 : END 143 : 144 : 145 : 146 : 147 :
© Cast3M 2003 - All rights reserved.
Disclaimer