C ENERCA SOURCE PV090527 24/01/19 21:15:04 11827 SUBROUTINE ENERCA(IPMODL,IPCHE1,IPCHE2,IPCHR) *_______________________________________________________________________ * * OPERATEUR DENSITE D'ENERGIE * * ENTREES : * --------- * * IPMODL POINTEUR SUR UN MMODEL * IPCHE1 POINTEUR SUR UN CHAMELEM * IPCHE2 POINTEUR SUR UN CHAMELEM * * * SORTIE : * -------- * * IPCHR POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT * CONTRACTE DES DEUX PRECEDENTS. * =0 SI L'OPERATION EST IMPOSSIBLE. * * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91 * *_______________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMMODEL -INC SMCHAML -INC SMINTE * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*72 MOT1,MOT2 CHARACTER*(NCONCH) CONM LOGICAL lsupde,lsupco * IPCHR=0 * NHRM=NIFOUR * MCHEL1=IPCHE1 MCHEL2=IPCHE2 SEGACT MCHEL1,MCHEL2 MOT1=MCHEL1.TITCHE MOT2=MCHEL2.TITCHE IFO1=MCHEL1.IFOCHE * * TEST DE COMPABILITE DES CHAMPS A MULTIPLIER * IF(MOT1.EQ.'CONTRAINTES'.AND.MOT2.EQ.'DEFORMATIONS') THEN IPCHEC = IPCHE1 IPCHED = IPCHE2 ICAS=1 ELSE IF(MOT2.EQ.'CONTRAINTES'.AND.MOT1.EQ.'DEFORMATIONS') THEN IPCHEC = IPCHE2 IPCHED = IPCHE1 * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER SONT INCOMPATIBLES ELSE MOTERR(1:8)=MOT1 MOTERR(9:16)=MOT2 CALL ERREUR(175) RETURN ENDIF * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES * CALL QUESUP(IPMODL,IPCHEC,5,0,ISUPCO,IRETCO) IF (ISUPCO.GT.1) RETURN * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE DEFORMATIONS * CALL QUESUP(IPMODL,IPCHED,5,0,ISUPDE,IRETDE) IF (ISUPDE.GT.1) RETURN * * ACTIVATION DU MODELE * MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) * KEL22 = 0 DO ISOUS=1,NSOUS IMODEL=KMODEL(ISOUS) SEGACT,IMODEL IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22+1 ENDDO * * CREATION DU CHAMELEM RESULTAT * N1=NSOUS-KEL22 N3=6 L1=8 SEGINI MCHELM TITCHE='SCALAIRE' IFOCHE=IFO1 * * DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES * isouss=0 DO 200 ISOUS=1,NSOUS * * QUELQUES INITIALISATIONS * IMODEL=KMODEL(ISOUS) C* SEGACT IMODEL MELE=NEFMOD if((MELE.EQ.22).OR.(MELE.EQ.259)) go to 200 MOSTRS = 0 MODEFO = 0 IVADEF = 0 IVASTR = 0 IPMINT = 0 lsupco=.false. lsupde=.false. * IPMAIL=IMAMOD CONM =CONMOD * * CREATION DU TABLEAU INFO * CALL IDENT (IPMAIL,CONM,IPCHEC,IPCHED,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9990 * * INFORMATION SUR L'ELEMENT FINI * * CALL ELQUOI (MELE,0,5,IPINF,IMODEL) * IF (IERR.NE.0) GOTO 9990 MFR=INFELE(13) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNNE(NUMGEO(MELE)) * MINTE=INFELE(11) * on saute les sous modeles n'ayant pas de fonctions de forme. Ex: contact if (infmod(/1).lt.7) goto 200 minte=infmod(7) if (minte.eq.0) goto 200 isouss=isouss+1 IPMINT=MINTE SEGACT,MINTE * IMACHE(ISOUSs)=IPMAIL CONCHE(ISOUSs)=CONMOD * INFCHE(ISOUSs,1)=0 INFCHE(ISOUSs,2)=0 INFCHE(ISOUSs,3)=NHRM INFCHE(ISOUSs,4)=MINTE INFCHE(ISOUSs,5)=0 INFCHE(ISOUSs,6)=5 * * RECHERCHE DES NOMS DE COMPOSANTES * NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' MOTYPE=NOTYPE * if(lnomid(4).ne.0) then nomid=lnomid(4) segact nomid mostrs=nomid nstr=lesobl(/2) nfac=lesfac(/2) else lsupco=.true. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) nomid=mostrs endif * CALL KOMCHA(IPCHEC,IPMAIL,CONM,MOSTRS, 1 MOTYPE,1,INFOS,3,IVASTR) IF (IERR.NE.0) THEN SEGSUP NOTYPE GOTO 9991 ENDIF IF(ISUPCO.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE, & MOSTRS,MELE) * if(lnomid(5) .ne.0) then nomid=lnomid(5) segact nomid ndef=lesobl(/2) modefo=nomid else lsupde=.true. CALL IDDEFO(IMODEL,IFOUR,MODEFO,NDEF,NFAC) nomid=modefo endif CALL KOMCHA(IPCHED,IPMAIL,CONM,MODEFO,MOTYPE, 1 1,INFOS,3,IVADEF) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9992 IF(ISUPDE.EQ.1)CALL VALCHE(IVADEF,NDEF,IPMINT,IPPORE, & MODEFO,MELE) * * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER * NSPTEL=0 NSEL =0 MPTVAL=IVASTR DO 1 ICOMP=1,NSTR MELVAL=IVAL(ICOMP) NSPTEL=MAX(NSPTEL,VELCHE(/1)) NSEL =MAX(NSEL ,VELCHE(/2)) 1 CONTINUE * NDPTEL=0 NDEL =0 MPTVAL=IVADEF DO 2 ICOMP=1,NDEF MELVAL=IVAL(ICOMP) NDPTEL=MAX(NDPTEL,VELCHE(/1)) NDEL =MAX(NDEL ,VELCHE(/2)) 2 CONTINUE * N1PTEL=MAX(NSPTEL,NDPTEL) N1EL =MAX(NSEL ,NDEL ) N2PTEL=0 N2EL =0 * N2=1 SEGINI MCHAML ICHAML(ISOUSs)=MCHAML NOMCHE(1)='SCAL' TYPCHE(1)='REAL*8' SEGINI MELVAL IELVAL(1)=MELVAL IPMELV=MELVAL * DO 310 IGAU=1,N1PTEL DO 310 IB=1,N1EL r_z=0.D0 * DO 366 ICOMP=1,NDEF MPTVAL=IVASTR MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XTT1=VELCHE(IGMN,IBMN) * MPTVAL=IVADEF MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XTT2=VELCHE(IGMN,IBMN) * r_z = r_z + XTT1*XTT2 366 CONTINUE MELVAL=IPMELV VELCHE(IGAU,IB)=r_z 310 CONTINUE * * DESACTIVATION PROPRE A LA GEOMETRIE ISOUS * MELVAL=IPMELV 9992 CONTINUE NOMID=MODEFO if(lsupde)SEGSUP NOMID IF(ISUPDE.EQ.1)THEN CALL DTMVAL(IVADEF,3) ELSE CALL DTMVAL(IVADEF,1) ENDIF 9991 CONTINUE NOMID=MOSTRS if(lsupco)SEGSUP NOMID IF(ISUPCO.EQ.1)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF 9990 CONTINUE * * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR IF (IERR.NE.0) THEN SEGSUP MCHELM IPCHR = 0 GOTO 999 ENDIF 200 CONTINUE IF (n1.ne.isouss) then n1 = isouss segadj mchelm endif * Fin du sous-programme IPCHR=MCHELM * 999 CONTINUE END