C CHASUP SOURCE OF166741 23/12/06 21:15:03 11803 C--------------------------------------------------------------------- C ENTREES: C C IPMODL Pointeur sur un MMODEL C IPOI1 Pointeur sur un MCHAML C IPLAC Indique le type de support demandé : C 1 scalaire aux NOEUDS C 2 scalaire au CENTRE DE GRAVITE C 3 scalaire aux points d'integration de la RAIDEUR C 4 scalaire aux points d'integration de la MASSE C 5 scalaire aux points de CONTRAINTES C C AM 14/6/07 SI IPLAC EST NEGATIF, ON RECUPERE UN CHAMP QUI C NE CONTIENT PAS LES COMPOSANTES COMPLEXES (NON SCALAIRES) C QU'ON A N'A PAS PU CHANGER C SINON, ON SORT EN ERREUR C C SORTIE: C C IPOI2 Pointeur sur un MCHAML C IRET =0 Si tout est ok C Sinon contient le numero d'erreur C C I.MONNIER le 31.05.90 C C--------------------------------------------------------------------- SUBROUTINE CHASUP(IPMODL,IPOI1,IPOI2,IRET,IPLAC) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMMODEL -INC SMCHAML -INC SMELEME -INC SMINTE -INC SMCOORD CHARACTER*8 CHARIN,CHARTY,MO24a,MO24b CHARACTER*(LOCOMP) MOCOMP SEGMENT SWORK REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN) REAL*8 SHP(6,NBNN) ,XE(3,NBNN) ENDSEGMENT SEGMENT SWORK2 INTEGER LETAB(N22) ENDSEGMENT * * NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2 * N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS * SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT * write(ioimp,*) 'coucou chasup' * write(ioimp,*) 'iplac=',iplac * write(ioimp,*) ' MCHAML' * call ecrobj('MCHAML ',IPOI1) * call prlist * CALL ACTOBJ('MCHAML ',IPOI1,1) * write(ioimp,*) ' MCHAML' * call ecrobj('MMODEL ',IPMODL) * call prlist * CALL ACTOBJ('MMODEL ',IPMODL,1) IRET =0 IPOIN1=0 call oooeta(mcoord,ieta,imod) C C ACTIVATION DU MODELE C MMODEL=IPMODL NSOUS1=KMODEL(/1) C C ACTIVATION DES MCHELM C MCHEL1 =IPOI1 NSOUS=MCHEL1.ICHAML(/1) IF(NSOUS.GT.NSOUS1)THEN * on va essayer de reduir le champ call reduaf(mchel1,mmodel,mchel2,0,ire,kerre) ** if (ire.ne.1) then ** call erreur(kerre) ** IRET=553 ** RETURN ** endif if (ire.eq.1) mchel1=mchel2 NSOUS=MCHEL1.ICHAML(/1) ENDIF N1=NSOUS L1=MCHEL1.TITCHE(/1) N3=MCHEL1.INFCHE(/2) NINF=N3 IF (N3.LT.6) N3=6 SEGINI MCHELM TITCHE=MCHEL1.TITCHE IFOCHE=IFOUR IPOI2=MCHELM iresu=0 C C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML C DO 100 ISOUS=1,NSOUS IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) DO IP=1,NINF INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP) ENDDO C C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE C MELEME=IMACHE(ISOUS) MO24a =CONCHE(ISOUS) INS=0 DO IO=1,NSOUS1 IMODEL=KMODEL(IO) IPMAIL=IMAMOD C C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY ') IF (IDARC.NE.0)THEN CALL LEKMOD(MMODEL,IPTABL,INEFMD) CHARIN = 'MAILLAGE' CALL LEKTAB(IPTABL,CHARIN, IOBRE) IF (IERR.NE.0) RETURN IPT1 = IOBRE IPMAIL= IOBRE IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN IPMAIL= IPT1.LISOUS(ISOUS) ENDIF ENDIF IF (IPMAIL.EQ.MELEME) INS=INS+1 ENDDO DO IO=1,NSOUS1 IMODEL=KMODEL(IO) C IPMAIL=imodel.IMAMOD C C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY ') IF(IDARC.NE.0)THEN CALL LEKMOD(MMODEL,IPTABL,INEFMD) CHARIN = 'MAILLAGE' CALL LEKTAB(IPTABL,CHARIN, IOBRE) IF (IERR.NE.0) RETURN IPT1 = IOBRE IPMAIL= IOBRE IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN IPMAIL= IPT1.LISOUS(ISOUS) ENDIF ENDIF MO24b=imodel.CONMOD IF (IPMAIL.EQ.MELEME.AND.(INS.GE.1.OR.MO24a.EQ.MO24b))GOTO $ 160 ENDDO * IRET=472 SEGSUP MCHELM RETURN * 160 CONTINUE MELE=NEFMOD c* write(6,*) 'chasup - mele ',mele,imodel,ipmail * on saute si element sans les supports if(mele.eq.22 ) go to 100 if(mele.eq.259) go to 100 if(mele.eq.107) go to 100 if(mele.eq.165) go to 100 if(mele.eq.261) go to 100 * * DANS LE CAS DES COQUES INTEGREES ON SORT EN ERREUR * IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN MINTE1=0 IPLACA=0 ELSE MINTE1=MCHEL1.INFCHE(ISOUS,4) IPLACA=MCHEL1.INFCHE(ISOUS,6) ENDIF C ithdm = 0 if (formod(1).eq.'LIAISON ') then IPLAC1 = 1 else IPLAC1 = ABS(IPLAC) IF ( IPLAC1 .EQ. 6 ) ithdm = 1 C le modele contient t il de la thermique OU diffusion OU metallurgie ? C ==> le segment d'integration est particulier IF ( FORMOD(1).EQ.'THERMIQUE ' .OR. & FORMOD(1).EQ.'DIFFUSION ' .OR. & FORMOD(1).EQ.'METALLURGIE ' ) THEN ithdm = 1 icov = 0 nmat = matmod(/2) CALL PLACE(matmod,nmat,iray,'RAYONNEMENT ') IF (icov+iray.EQ.0) THEN IF ( IPLAC1 .GT. 2 ) IPLAC1 = 6 ENDIF IF(MELE .EQ. 265)THEN C Cas des JOI1 ==> Ressorts THERMIQUES C ============ ithdm = 0 IPLAC1 = 1 ENDIF ENDIF endif C IF (ithdm.NE.0 .AND. IPLAC1.GT.1) THEN IF (IPLAC1.EQ.1) CALL TSHAPE(MELE,'NOEUD ',IPMINT) IF (IPLAC1.EQ.2) CALL TSHAPE(MELE,'GRAVITE',IPMINT) IF (IPLAC1.EQ.6) CALL TSHAPE(MELE,'GAUSS ',IPMINT) IF (IERR .NE. 0) GOTO 665 MINTE=IPMINT MELGEO=NUMGEO(MELE) ELSE if(2+iplac1.gt.infmod(/1))then CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL) IF ( IERR .NE. 0) GOTO 665 INFO=IPTR2 MINTE=INFELL(11) MELGEO=INFELL(14) SEGSUP,INFO else minte=infmod(2+iplac1) MELGEO=INFELE(14) endif ENDIF INFCHE(ISOUS,4)=MINTE IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0 INFCHE(ISOUS,6)=IPLAC1 C C ON RECUPERE LE NOMBRE D ELEMENTS C NBNN =NUM(/1) NBELEM=NUM(/2) C C ON RECUPERE LE NOMBRE DE POINTS SUPPORT C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU C IF(MINTE1.NE.0)THEN NBPGA1 = MINTE1.SHPTOT(/3) ELSE NBPGA1=NBNN ENDIF if (minte.eq.0) then call erreur(5) return endif NBPGAU = SHPTOT(/3) nbpga1=max(nbpga1,nbpgau) C NEL =NBELEM SEGINI SWORK C C PREPARATION POUR CREATION DU MCHAML C MCHAM1=MCHEL1.ICHAML(ISOUS) C N22 = MCHAM1.NOMCHE(/2) * * SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER * SEGINI SWORK2 * IF(IPLAC.GE.0) THEN N2 = N22 DO ICOMP=1,N22 LETAB(ICOMP) = ICOMP ENDDO * ELSE * * BOUCLE SUR LES COMPOSANTES * JECO = 0 DO ICOMP=1,N22 C CHARTY=MCHAM1.TYPCHE(ICOMP) MELVA1=MCHAM1.IELVAL(ICOMP) LETAB(ICOMP) = 0 * IF(CHARTY(1:6).EQ.'REAL*8') THEN JECO = JECO + 1 LETAB(ICOMP) = JECO ENDIF * * cas de variables complexes * IF(CHARTY(1:8).EQ.'POINTEUR') THEN N2PTE1=MELVA1.IELCHE(/1) * * ... Comme on ne sait pas extrapoler ou interpoler de variables * composées, on n'en accepte qu'une par élément ... IF(N2PTE1.EQ.1) THEN JECO = JECO + 1 LETAB(ICOMP) = JECO ENDIF ENDIF ENDDO N2 = JECO * ENDIF * * CREATION DU MCHAML * SEGINI MCHAML iresu=iresu+1 ICHAML(iresu)=MCHAML C C BOUCLE SUR LES COMPOSANTES EN ENTREE C DO 180 ICOMP=1,N22 C JCOMP = LETAB(ICOMP) IF(JCOMP.EQ.0) GO TO 180 NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP) TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP) C MELVA1=MCHAM1.IELVAL(ICOMP) * * RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire * IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN 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 SEGSUP SWORK,SWORK2,MCHAML IRET=146 MOTERR(1:8)='CHASUP ' GO TO 665 ENDIF * N1PAUX=N1PTE1 C C----------------------------------------------------------------------- C PETIT TEST POUR LE COQ4 C SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE C LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT C IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4 C----------------------------------------------------------------------- C ELSE N1PTEL=0 N1EL=0 ENDIF * * ... Et dans le cas de variables complexes ... * IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN N2PTE1=MELVA1.IELCHE(/1) IF (N2PTE1.EQ.1) THEN N2PTEL=1 ELSE N2PTEL=NBPGAU ENDIF N2EL =MELVA1.IELCHE(/2) * * ... Comme on ne sait pas extrapoler ou interpoler de variables * composées, on n'en accepte qu'une par élément ... * IF(N2PTEL.NE.1) THEN * SEGSUP SWORK,SWORK2,MCHAML * IRET=755 * GO TO 665 * ENDIF * * PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS * IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN SEGSUP SWORK,SWORK2,MCHAML IRET=146 MOTERR(1:8)='CHASUP ' GO TO 665 ENDIF ELSE N2PTEL=0 N2EL=0 ENDIF SEGINI MELVAL IELVAL(JCOMP)=MELVAL * * TRAITEMENT IMMEDIAT SI CHAMP CONSTANT * * if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq IF(n2ptel.ne.0) then IF(N2PTEL.EQ.1) THEN DO 4119 IEL=1,N2EL IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL) 4119 CONTINUE C* ELSE IF (N2PTEL.NE.1) THEN ELSE IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN SEGSUP SWORK,SWORK2,MCHAML IRET=755 GO TO 665 ENDIF DO 4109 IGAU=1,N2PTEL DO 41091 IEL=1,N2EL IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL) 41091 CONTINUE 4109 CONTINUE ENDIF else IF(N1PTE1.EQ.1) THEN DO 4120 IEL=1,N1EL VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL) 4120 CONTINUE * ELSE * * write (6,*) melva1.velche(/1),melva1.velche(/2) DO 3120 IEL=1,NEL IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130 DO 3121 IGAU=1,N1PTE1 VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL) 3121 CONTINUE * write(6,*) 'MINTE1 = ',minte1 C C 1-ER CAS : LE CHAMELEM N'EST PAS AUX NOEUDS C IF(MINTE1.NE.0)THEN C C MEME SUPPORT? ( attention test sur iplaca et iplac1 pour DKT) C * write(6,*) ' meme support?',minte,minte1,iplac1,iplaca IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA) $ THEN DO 3124 IGAU=1,N1PTE1 VELCHE(IGAU,IEL)=VAL1(IGAU) 3124 CONTINUE C C SUPPORTS DIFFERENTS C ELSE C C COQUE INTEGREE OU PAS ? C IF(INFMOD(/1).NE.0)THEN NPINT=INFMOD(1) ELSE NPINT=0 ENDIF IF (NPINT.NE.0.AND.NPINT.NE.1)THEN IRET = 19 SEGSUP SWORK,SWORK2,MCHAML,MELVAL GO TO 665 ENDIF C if (ieta.ne.1) then ieta=1 segact mcoord endif 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 IRET=KERRE SEGSUP SWORK,SWORK2,MCHAML,MELVAL GO TO 665 ENDIF * DO 3122 IGAU=1,N1PTEL VELCHE(IGAU,IEL)=VAL2(IGAU) 3122 CONTINUE ENDIF C C 2-EME CAS : LE CHAMELEM EST AUX NOEUDS C ELSE * * AM 1/4/16 CAS PARTICULIER DES JOINTS * IF( MELGEO.EQ.12.OR.MELGEO.EQ.13 & .OR.MELGEO.EQ.29.OR.MELGEO.EQ.30 & .OR.MELGEO.EQ.31) THEN * IF(((IPLACA.EQ.0.OR.IPLACA.EQ.1).AND. $ IPLAC1.EQ.1).AND.(N1PTEL.EQ.N1PTE1)) $ THEN DO IGAU=1,N1PTE1 VELCHE(IGAU,IEL)=VAL1(IGAU) ENDDO ELSE * IDECA=0 IF(MELGEO.EQ.29) IDECA=2 IF(MELGEO.EQ.30) IDECA=3 IF(MELGEO.EQ.31) IDECA=4 NBNOU=NBNN-IDECA NBNOV=SHPTOT(/2)-IDECA * MOCOMP=NOMCHE(JCOMP) IF (MOCOMP.EQ.'P '.OR. & MOCOMP.EQ.'PQ '.OR. & MOCOMP.EQ.'TP ' ) THEN DO IGAU=1,N1PTEL VALG=0.D0 DO INO=1,IDECA INO1 = NBNOU + INO INO2 = NBNOV + INO VALG=VALG+SHPTOT(1,INO2,IGAU) $ *VAL1(INO1) ENDDO VELCHE(IGAU,IEL)=VALG ENDDO ELSE DO IGAU=1,N1PTEL VALG=0.D0 DO INO=1,NBNOU VALG=VALG+SHPTOT(1,INO,IGAU) $ *VAL1(INO) ENDDO VELCHE(IGAU,IEL)=VALG/2.D0 ENDDO ENDIF ENDIF ELSE DO IGAU=1,N1PTEL VALG=0.D0 DO INO=1,NBNN VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO) ENDDO VELCHE(IGAU,IEL)=VALG ENDDO ENDIF ENDIF 3120 CONTINUE 3130 CONTINUE ENDIF endif 180 CONTINUE SEGSUP SWORK,SWORK2 100 CONTINUE if (iresu.ne.nsous) then n1=iresu segadj mchelm endif 665 CONTINUE c return END