C VARICA SOURCE PV 13/04/12 21:16:00 7756 SUBROUTINE VARICA(IPOI1,IPOI2,IPMODL,IRET,MICHE,JEMIL) *____________________________________________________________________ * * Calcul d'un champ variable appele par VARI * * ENTREES : * --------- * * IPOI1 Pointeur sur un MCHAML ou un CHPOINT * IPOI2 Pointeur sur un EVOLUTIO * IPMODL Pointeur sur un MMODEL * MICHE = 1 si on a lu un CHPOINT * JEMIL = 1 A 5 selon le support choisit * * * SORTIE : * -------- * * IRET Pointeur sur le MCHAML resultat * =0 si operation impossible * * Passage aux nouveaux CHAMELEMs par JM CAMPENON LE 05/91 * *____________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC SMCHAML -INC SMCHPOI -INC SMMODEL -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC SMELEME -INC SMINTE -INC SMCOORD * SEGMENT MTRAX REAL*8 XX(0) ENDSEGMENT * SEGMENT MTRAY REAL*8 YY(0) ENDSEGMENT * SEGMENT SWORK REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN) REAL*8 SHP(6,NBNN) ,XE(3,NBNN) ENDSEGMENT * SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT * CHARACTER*4 MOTREF,MOTABS * IPOIC=IPOI1 * * On recupere l'objet evolution * MEVOLL=IPOI2 SEGACT MEVOLL KEVOLL=IEVOLL(1) SEGACT KEVOLL MLREEL=IPROGX MLREE1=IPROGY MOTABS=NOMEVX(1:4) SEGDES KEVOLL * SEGACT MLREEL,MLREE1 NBPOIX=PROG(/1) NBPOIY=MLREE1.PROG(/1) * IF(NBPOIX.NE.NBPOIY) THEN CALL ERREUR(263) SEGDES MLREEL,MLREE1 SEGDES MEVOLL RETURN ENDIF * SEGINI MTRAX SEGINI MTRAY DO 695 I=1,NBPOIX XX(**)=PROG(I) 695 CONTINUE * DO 696 I=1,NBPOIY YY(**)=MLREE1.PROG(I) 696 CONTINUE * SEGDES MLREEL,MLREE1 SEGDES MEVOLL * * Traitement du CHPOINT - Recherche du nombre de composantes * IF(MICHE.EQ.0) GO TO 231 * IVID=1 IPOI11=IPOI1 MCHPO1=IPOI1 SEGACT MCHPO1 NSOUP1=MCHPO1.IPCHP(/1) * DO 329 IA=1,NSOUP1 MSOUP1=MCHPO1.IPCHP(IA) SEGACT MSOUP1 NC1=MSOUP1.NOCOMP(/2) IF(NC1.EQ.1) GO TO 321 * 325 CONTINUE SEGDES MSOUP1 MOTREF=MOTABS GO TO 320 * 321 CONTINUE IF(IA.EQ.1) THEN MOTREF=MSOUP1.NOCOMP(1) GO TO 330 ENDIF * IF(MOTREF.NE.MSOUP1.NOCOMP(1)) GOTO 325 * 330 CONTINUE SEGDES MSOUP1 * 329 CONTINUE * 320 CONTINUE SEGDES MCHPO1 IF(MOTREF.EQ.MOTABS) THEN IVID=0 CALL EXCOPP(IPOI1,MOTABS,IPOI11,'SCAL',IVID) IF(IERR.NE.0) THEN SEGSUP MTRAX,MTRAY IRET=0 RETURN ENDIF ENDIF * * On convertit le CHPOINT en MCHAML * IF(MICHE.EQ.1) THEN CALL CHAME1 (0,IPMODL,IPOI11,' ',IPOIC,JEMIL) IF (IVID.EQ.0) THEN CALL DTCHPO(IPOI11) ENDIF IF (IERR.NE.0) THEN SEGSUP MTRAX,MTRAY IRET=0 RETURN ENDIF ENDIF * 231 CONTINUE * MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) * MCHEL1=IPOIC SEGACT MCHEL1 NINF=MCHEL1.INFCHE(/2) * * Creation du MCHAML * N1=NSOUS N3=6 L1=8 SEGINI MCHELM IRET=MCHELM IFOCHE=IFOUR TITCHE='SCALAIRE' * * Boucle sur les sous zone du MCHAML * DO 100 ISOUS=1,NSOUS * IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) DO 191 IP=1,NINF INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP) 191 CONTINUE * * Mise en concordance des pointeurs de maillage * MELEME=IMACHE(ISOUS) DO 150 IO=1,NSOUS IMODEL=KMODEL(IO) SEGACT IMODEL IF (IMAMOD.EQ.MELEME.AND.CONMOD.EQ.CONCHE(ISOUS)) GOTO 160 SEGDES IMODEL 150 CONTINUE CALL ERREUR (472) GOTO 9910 * 160 MELE=NEFMOD IPTR3=0 IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN * * La sous zone est aux noeuds * if(infmod(/1).lt.3) then CALL ELQUOI(MELE,0,1,IPTR3,IMODEL) IF (IERR.NE.0) GOTO 9910 INFO=IPTR3 MINTE1=INFELL(11) segsup info else MINTE1=INFMOD(3) endif ELSE MINTE1=MCHEL1.INFCHE(ISOUS,4) ENDIF SEGACT MINTE1 * * Information sur l'element fini * * if(infmod(/1).lt.2+jemil)then CALL ELQUOI(MELE,0,JEMIL,IPTR2,IMODEL) IF (IERR.NE.0) GOTO 9920 INFO=IPTR2 MINTE=INFELL(11) MELGEO=INFELL(14) segsup info else MINTE=INFMOD(2+JEMIL) MELGEO=INFELE(14) endif SEGACT MINTE INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,6)=JEMIL * * On recupere le nombre de points support NBPGA1 pour l'ancien ch * NBPGAU pour le nouveau * NBPGA1 = MINTE1.SHPTOT(/3) NBPGAU = SHPTOT(/3) * * On recupere le nombre d'element * SEGACT MELEME NBNN =NUM(/1) NBELEM=NUM(/2) * NEL =NBELEM SEGINI SWORK * * Recherche de la composante * MCHAM1=MCHEL1.ICHAML(ISOUS) SEGACT MCHAM1 IF (MCHAM1.IELVAL(/1).EQ.1) THEN * * pour les champ a une composante pas de verif. de MOTABS * IPLAC=1 GOTO 104 ENDIF * * Recherche du nom MOTABS * CALL PLACE (MCHAM1.NOMCHE,MCHAM1.NOMCHE(/2),IPLAC,MOTABS) * 104 CONTINUE IF (IPLAC.EQ.0) THEN * * On a pas trouve la composante * MOTERR(1:8)=MOTABS CALL ERREUR(243) GOTO 9930 ELSE IF (MCHAM1.TYPCHE(IPLAC).NE.'REAL*8') THEN MOTERR(1:4)='VARI' MOTERR(5:8)=MCHAM1.NOMCHE(IPLAC) CALL ERREUR (335) GOTO 9930 ENDIF ENDIF * * Creation du MCHAML de la sous zone * N2=1 SEGINI MCHAML ICHAML(ISOUS)=MCHAML TYPCHE(1)='REAL*8' NOMCHE(1)='SCAL' MELVA1=MCHAM1.IELVAL(IPLAC) SEGACT MELVA1 * * Recherche de la taille du nouveau chamelem * N1PTE1=MELVA1.VELCHE(/1) IF (N1PTE1.EQ.1) THEN N1PTEL=1 ELSE N1PTEL=NBPGAU ENDIF N1EL =MELVA1.VELCHE(/2) * * Petit test de compatibilite des nombres d'elements * IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN MOTERR(1:8)='VARI' CALL ERREUR(146) GOTO 9940 ENDIF * N1PAUX=N1PTE1 * * Pour les COQ4, le nb de pt de GAUSS vaut 5, mais on * ne prend que les 4 premiers (le 5ieme sert uniquement * au cisaillement) * IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4 * N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(1)=MELVAL * * Traitement immediat si champ constant * IF(N1PTE1.EQ.1) THEN DO 4120 IEL=1,N1EL XTT1 =MELVA1.VELCHE(1,IEL) CALL VARIFO(XX,YY,NBPOIX,XTT1,YTT1,KERRE) IF(KERRE.NE.0) THEN CALL ERREUR(KERRE) GOTO 9950 ENDIF VELCHE(1,IEL)= YTT1 4120 CONTINUE * ELSE * DO 3120 IEL=1,NEL DO 3121 IGAU=1,N1PTE1 XTT1=MELVA1.VELCHE(IGAU,IEL) CALL VARIFO(XX,YY,NBPOIX,XTT1,YTT1,KERRE) IF(KERRE.NE.0) THEN CALL ERREUR(KERRE) GOTO 9950 ENDIF VAL1(IGAU)=YTT1 3121 CONTINUE * * Meme support * IF(MINTE.EQ.MINTE1) THEN DO 3124 IGAU=1,N1PTE1 VELCHE(IGAU,IEL)=VAL1(IGAU) 3124 CONTINUE GO TO 3120 * * Support different * ELSE CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) CALL QUEDIM(MELGEO,KERRE) CALL CH1CH2 (MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,SWORK, > KERRE) IF(KERRE.NE.0) THEN CALL ERREUR(KERRE) GOTO 9950 ENDIF * DO 3122 IGAU=1,N1PTEL VELCHE(IGAU,IEL)=VAL2(IGAU) 3122 CONTINUE ENDIF 3120 CONTINUE * ENDIF SEGDES MELVAL,MELVA1 SEGSUP SWORK SEGDES MCHAML,MCHAM1,IMODEL,MELEME * * INFO=IPTR2 * SEGSUP INFO * * INFO=IPTR3 * IF (INFO.NE.0) SEGSUP INFO * IF (MINTE.NE.0) SEGDES MINTE IF (MINTE1.NE.0) SEGDES MINTE1 100 CONTINUE * SEGDES MCHELM SEGDES MCHEL1 SEGDES MMODEL IF(MICHE.EQ.1) CALL DTCHAM(IPOIC) SEGSUP MTRAX,MTRAY SEGDES MELEME RETURN * * Erreur dans une sous zone / desactivation et retour * 9950 CONTINUE SEGSUP MELVAL * 9940 CONTINUE SEGDES MELVA1 SEGSUP MCHAML * 9930 CONTINUE SEGDES MCHAM1 * INFO=IPTR2 * SEGSUP INFO SEGDES MELEME SEGSUP SWORK * 9920 CONTINUE * INFO=IPTR3 * IF (INFO.NE.0) SEGSUP INFO * 9910 CONTINUE IRET=0 SEGDES IMODEL SEGDES MMODEL SEGDES MCHEL1 SEGSUP MCHELM SEGSUP MTRAX,MTRAY IF(MICHE.EQ.1) CALL DTCHAM(IPOIC) * RETURN END