C VARIN2 SOURCE OF166741 25/02/20 21:17:58 12165 SUBROUTINE VARIN2(ICHAM2,MELVA1,COQ,MELEME,SWORK,NOMCO,MELE, & MELGEO,MINTE,MINTE1,MELVAL,KERRE) *____________________________________________________________________ * * OBJET : Variation d'un champ/élément ayant une ou des composante(s) * °°°°°°° de type EVOLUTION en fonction d'un champ/point ou * d'un champ/élément.Ce champ peut avoir plusieurs composantes * si necessaire. Dans ce cas il est possible d'instancier * un champ/element dont les composantes dependent de * parametres differents en chaque point. * Routine appelee par varinu.eso * * * SORTIE : * °°°°°°°° * * MELVAL Pointeur sur le MCHAML resultat * KERRE Diagnostic d'erreur * *_____________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC SMCHAML -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC SMELEME -INC SMINTE -INC SMCOORD C CHARACTER*(LOCOMP) NOM2,NOMTT,NOM4,NOM3,NOMCO LOGICAL COQ C C Creation des segments SEGMENT SWORK REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN) REAL*8 SHP(6,NBNN) ,XE(3,NBNN) ENDSEGMENT SEGMENT IAMOI REAL*8 VEL1(MG1,N1EL2),VEL2(MG2,MXNBE) ENDSEGMENT C DATA NOMTT/'T '/ C KERRE =0 ICHAN =0 IPOIN1=0 C MCHAM2=ICHAM2 NBNN =NUM(/1) NEL0 =NUM(/2) NBPGAU=SHPTOT(/3) N1PTE3=MELVA1.IELCHE(/1) N1EL3 =MELVA1.IELCHE(/2) NCO1 = MCHAM2.IELVAL(/1) IEVOL = MELVA1.IELCHE(1,1) MEVOLL= IEVOL KEVOLL= IEVOLL(1) NOM3 = NOMEVY NOM4 = NOMEVX C C Cas des coques dont les caracteristiques dependent de T C IF (COQ.AND.NOM4.EQ.NOMTT) THEN INO2 = 0 INO1 = 0 INO3 = 0 DO 10 INO = 1,NCO1 NOM2 = MCHAM2.NOMCHE(INO) IF (NOM2.EQ.NOMTT ) INO2=INO IF (NOM2.EQ.'TINF ') INO1=INO IF (NOM2.EQ.'TSUP ') INO3=INO 10 CONTINUE IF (INO1.NE.0.AND.INO2.NE.0.AND.INO3.NE.0) THEN C MELVA3=MCHAM2.IELVAL(INO1) MELVA4=MCHAM2.IELVAL(INO3) C NBP2=MELVA4.VELCHE(/1) NBP1=MELVA3.VELCHE(/1) NEL1=MELVA3.VELCHE(/2) NEL2=MELVA4.VELCHE(/2) N1PTEL=MAX(NBP1,NBP2) N1EL =MAX(NEL1,NEL2) N2PTEL=0 N2EL =0 SEGINI MELVA5 DO 20 IGAU=1,N1PTEL IGMN1=MIN(IGAU,MELVA3.VELCHE(/1)) IGMN2=MIN(IGAU,MELVA4.VELCHE(/1)) DO 30 IB=1,N1EL IBMN1=MIN(IB,MELVA3.VELCHE(/2)) IBMN2=MIN(IB,MELVA4.VELCHE(/2)) MELVA5.VELCHE(IGAU,IB)=MELVA3.VELCHE(IGMN1,IBMN1)+ & MELVA4.VELCHE(IGMN2,IBMN2) 30 CONTINUE 20 CONTINUE C MELVA3=MCHAM2.IELVAL(INO2) C N1PTEL = MELVA3.VELCHE(/1) N1EL = MELVA3.VELCHE(/2) N2PTEL = 0 N2EL = 0 SEGINI MELVA4 DO 40 II = 1,N1PTEL DO 50 III = 1,N1EL MELVA4.VELCHE(II,III) = 4.D0*MELVA3.VELCHE(II,III) 50 CONTINUE 40 CONTINUE C NBP2=MELVA4.VELCHE(/1) NBP1=MELVA5.VELCHE(/1) NEL1=MELVA5.VELCHE(/2) NEL2=MELVA4.VELCHE(/2) N1PTEL=MAX(NBP1,NBP2) N1EL =MAX(NEL1,NEL2) N2PTEL=0 N2EL =0 SEGINI MELVA6 DO 60 IGAU=1,N1PTEL IGMN1=MIN(IGAU,MELVA5.VELCHE(/1)) IGMN2=MIN(IGAU,MELVA4.VELCHE(/1)) DO 70 IB=1,N1EL IBMN1=MIN(IB,MELVA5.VELCHE(/2)) IBMN2=MIN(IB,MELVA4.VELCHE(/2)) MELVA6.VELCHE(IGAU,IB)=MELVA5.VELCHE(IGMN1,IBMN1)+ & MELVA4.VELCHE(IGMN2,IBMN2) 70 CONTINUE 60 CONTINUE SEGSUP MELVA4,MELVA5 C N1PTEL = MELVA6.VELCHE(/1) N1EL = MELVA6.VELCHE(/2) N2PTEL = 0 N2EL = 0 SEGINI MELVA2 DO 80 II = 1,N1PTEL DO 90 III = 1,N1EL MELVA2.VELCHE(II,III) = 1.D0/6.D0*MELVA6.VELCHE(II,III) 90 CONTINUE 80 CONTINUE SEGSUP MELVA6 C GOTO 100 ELSEIF (INO2.NE.0) THEN MELVA2=MCHAM2.IELVAL(INO2) GOTO 100 ENDIF ELSE DO 110 INO = 1,NCO1 NOM2 = MCHAM2.NOMCHE(INO) IF (NOM3.EQ.NOMCO.or.(nomco.eq.'MOCO'.and.NOM3.eq.'RAID').or. &(nomco.eq.'MOCO'.and.NOM3.eq.'VISC')) & THEN IF (NOM4.EQ.NOM2.OR.(NOM2.EQ.'TEMP'.AND.NOM4.EQ.'FREQ')) & THEN MELVA2=MCHAM2.IELVAL(INO) GOTO 100 ENDIF ENDIF 110 CONTINUE ENDIF C KERRE=665 RETURN C 100 CONTINUE C C On teste la taille de MCHAML_FLOTTANT N1PTE2=MELVA2.VELCHE(/1) N1EL2 =MELVA2.VELCHE(/2) IF (N1EL2.NE.NEL0.AND.N1EL2.NE.1.AND.NEL0.NE.1) THEN KERRE=146 RETURN ENDIF IF (N1PTE2.NE.1.AND.N1PTE2.NE.NBPGAU) THEN KERRE=146 RETURN ENDIF C On teste la taille entre MCHAML_EVOLUTION et MCHAML_FLOTTANT IF (N1EL2.NE.N1EL3.AND.N1EL2.NE.1.AND.N1EL3.NE.1) THEN KERRE=146 RETURN ENDIF C Si MCHAML_FLOTTANT ou la loi de variation n'est pas constant C et de plus leur support geometrique est different, alors on C change le support de MCHAML_FLOTTANT (MINTE) vers le support C de MCHAML_EVOLUTION (MINTE1). Quand l'interpolation est finie, C on change le support geometrique de MCHAML_FLOTTANT resultat C vers le support demandé (MINTE). C Tableau VEL1 contient les valeurs au support MINTE1 C Tableau VEL2 contient les valeurs interpolées selon C la loi de variation et appuyées au support MINTE1 MXNBE=MAX(N1EL2,N1EL3) IF (N1PTE3.NE.1.AND.MINTE.NE.MINTE1) THEN ICHAN=1 IF (N1PTE2.EQ.1) THEN MG1=1 ELSE MG1=N1PTE3 ENDIF MG2=N1PTE3 SEGINI IAMOI CALL ZERO(VEL1,MG1,N1EL2) CALL ZERO(VEL2,MG2,MXNBE) C Pour les COQ4, le nb de pt de GAUSS vaux 5, mais C on ne prend que les 4 premiers N1PAUX=N1PTE2 IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4 DO 120 IEL=1,N1EL2 IF (N1PTE2.EQ.1) THEN VEL1(1,IEL)=MELVA2.VELCHE(1,IEL) ELSE DO 130 IGAU=1,N1PTE2 VAL1(IGAU)=MELVA2.VELCHE(IGAU,IEL) 130 CONTINUE IF (MINTE1.NE.0) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) CALL QUEDIM(MELGEO,KERRE) CALL CH1CH2(MELE,MINTE1,MINTE,N1PTE3,N1PAUX,NBNN,SWORK, & IPOIN1,KERRE) IF (KERRE.NE.0) THEN SEGSUP IAMOI RETURN ENDIF DO 140 IGAU=1,N1PTE3 VEL1(IGAU,IEL)=VAL2(IGAU) 140 CONTINUE ELSE DO 150 IGAU=1,N1PTE3 VALG=0.D0 DO 160 INO=1,NBNN VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO) 160 CONTINUE VEL1(IGAU,IEL)=VALG 150 CONTINUE ENDIF ENDIF 120 CONTINUE ELSE MG2=NBPGAU IF (N1PTE2.EQ.1.AND.N1PTE3.EQ.1) MG2=1 ENDIF C Recherche de la taille du nouveau chamelem N2PTEL=0 N2EL =0 N1PTEL=NBPGAU N1EL =MXNBE IF (N1PTE2.EQ.1.AND.N1PTE3.EQ.1) N1PTEL=1 SEGINI MELVAL C Boucle sur les points de gauss et les éléments DO 170 IEL=1,MXNBE DO 180 IGAU=1,MG2 IG=IGAU IF (N1PTE3.EQ.1) IG=1 IE=IEL IF (N1EL3.EQ.1) IE=1 C On active l'objet EVOLUTION IEVOL =MELVA1.IELCHE(IG,IE) MEVOLL=IEVOL KEVOLL=IEVOLL(1) MLREEL=IPROGX MLREE1=IPROGY INEW=0 LON =PROG(/1) C C test pour renverser les suites si ls premiere est decroissante C IF (PROG(LON) .LT. PROG(1)) THEN JG=LON JFIN=LON+1 SEGINI MLREE2,MLREE3 INEW=1 DO 190 IO=1,LON MLREE2.PROG(IO)=PROG(JFIN-IO) MLREE3.PROG(IO)=MLREE1.PROG(JFIN-IO) 190 CONTINUE MLREEL=MLREE2 MLREE1=MLREE3 ENDIF C C Interpolation linéaire C CB215821 : Cas de LISTREEL de 1 seule valeur => resultat connu ! IF(PROG(/1) .EQ. 1) THEN VAINT = MLREE1.PROG(1) ELSE C On cherche la valeur à interpoler IG=IGAU IE=IEL IF (ICHAN.EQ.1) THEN IF (VEL1(/1).EQ.1) IG=1 IF (VEL1(/2).EQ.1) IE=1 VA1=VEL1(IG,IE) ELSE IF (N1PTE2.EQ.1) IG=1 IF (N1EL2 .EQ.1) IE=1 VA1=MELVA2.VELCHE(IG,IE) ENDIF DO 200 IP=2,PROG(/1) I1=IP IF (PROG(IP).GT.VA1) GOTO 210 200 CONTINUE 210 CONTINUE I2=I1-1 IF(PROG(I1)-PROG(I2).EQ.0.) THEN KERRE = 835 IF (INEW.EQ.1) THEN SEGSUP MLREEL,MLREE1 ENDIF RETURN ENDIF PENTE=(MLREE1.PROG(I1)-MLREE1.PROG(I2))/ & (PROG(I1)-PROG(I2)) VAINT=MLREE1.PROG(I2)+PENTE*(VA1-PROG(I2)) * kich : valeur hors segment Valeur egale a la borne depassee if (va1.lt.prog(1)) vaint=MLREE1.PROG(1) if (va1.gt.prog(prog(/1))) vaint=MLREE1.PROG(PROG(/1)) * write(6,fmt='(1X,''IGAU,IEL,VA1,VEL2'',2I6,2E13.5)') * IGAU,IEL,VA1,VAINT ENDIF IF (ICHAN.EQ.1) THEN VEL2(IGAU,IEL)=VAINT ELSE VELCHE(IGAU,IEL)=VAINT ENDIF C IF (INEW.EQ.1) THEN SEGSUP MLREEL,MLREE1 ENDIF 180 CONTINUE 170 CONTINUE C On change les valeurs interpolées au support demandé IF (ICHAN.EQ.1) THEN N1PAUX=N1PTE3 IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4 DO 220 IEL=1,MXNBE DO 230 IGAU=1,N1PTE3 VAL1(IGAU)=VEL2(IGAU,IEL) 230 CONTINUE IF (MINTE1.NE.0) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) CALL QUEDIM(MELGEO,KERRE) CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,SWORK, & IPOIN1,KERRE) IF (KERRE.NE.0) THEN SEGSUP IAMOI RETURN ENDIF DO 240 IGAU=1,N1PTEL VELCHE(IGAU,IEL)=VAL2(IGAU) 240 CONTINUE ELSE DO 250 IGAU=1,N1PTEL VALG=0.D0 DO 260 INO=1,NBNN VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO) 260 CONTINUE VELCHE(IGAU,IEL)=VALG 250 CONTINUE ENDIF 220 CONTINUE ENDIF END