Télécharger la plaquette Cast3M


fr en

Télécharger enerca.eso

Retour à la liste

Numérotation des lignes : 

enerca

  1. C ENERCA    SOURCE    CB215821  24/04/12    21:15:45     11897          
  2.       SUBROUTINE ENERCA(IPMODL,IPCHE1,IPCHE2,IPCHR)
  3. *_______________________________________________________________________
  4. *
  5. *       OPERATEUR DENSITE D'ENERGIE
  6. *
  7. *  ENTREES :
  8. *  ---------
  9. *
  10. *     IPMODL  POINTEUR SUR UN MMODEL
  11. *     IPCHE1  POINTEUR SUR UN CHAMELEM
  12. *     IPCHE2  POINTEUR SUR UN CHAMELEM
  13. *
  14. *
  15. *  SORTIE :
  16. *  --------
  17. *
  18. *     IPCHR   POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT
  19. *             CONTRACTE DES DEUX PRECEDENTS.
  20. *             =0 SI L'OPERATION EST IMPOSSIBLE.
  21. *
  22. *  PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91
  23. *
  24. *_______________________________________________________________________
  25. *
  26.       IMPLICIT INTEGER(I-N)
  27.       IMPLICIT REAL*8(A-H,O-Z)
  28. *
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCGEOME
  33. -INC SMMODEL
  34. -INC SMCHAML
  35. -INC SMINTE
  36. *
  37.       SEGMENT NOTYPE
  38.         CHARACTER*16 TYPE(NBTYPE)
  39.       ENDSEGMENT
  40. *
  41.       SEGMENT MPTVAL
  42.         INTEGER IPOS(NS)    ,NSOF(NS)
  43.         INTEGER      IVAL(NCOSOU)
  44.         CHARACTER*16 TYVAL(NCOSOU)
  45.       ENDSEGMENT
  46. *
  47.       PARAMETER ( NINF=3 )
  48.       INTEGER INFOS(NINF)
  49.       CHARACTER*72 MOT1,MOT2
  50.       CHARACTER*(NCONCH) CONM
  51.       LOGICAL lsupde,lsupco
  52. *
  53.       IPCHR=0
  54. *
  55.       NHRM=NIFOUR
  56. *
  57.       MCHEL1=IPCHE1
  58.       MCHEL2=IPCHE2
  59.       SEGACT MCHEL1,MCHEL2
  60.       MOT1=MCHEL1.TITCHE
  61.       MOT2=MCHEL2.TITCHE
  62.       IFO1=MCHEL1.IFOCHE
  63. *
  64. *  TEST DE COMPABILITE DES CHAMPS A MULTIPLIER
  65. *
  66.       IF(MOT1.EQ.'CONTRAINTES'.AND.MOT2.EQ.'DEFORMATIONS') THEN
  67.          IPCHEC = IPCHE1
  68.          IPCHED = IPCHE2
  69.          ICAS=1
  70.       ELSE IF(MOT2.EQ.'CONTRAINTES'.AND.MOT1.EQ.'DEFORMATIONS') THEN
  71.          IPCHEC = IPCHE2
  72.          IPCHED = IPCHE1
  73. * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER SONT INCOMPATIBLES
  74.       ELSE
  75.          MOTERR(1:8)=MOT1
  76.          MOTERR(9:16)=MOT2
  77.          CALL ERREUR(175)
  78.          RETURN
  79.       ENDIF
  80. *
  81. *    VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES
  82. *
  83.       CALL QUESUP(IPMODL,IPCHEC,5,0,ISUPCO,IRETCO)
  84.       IF (ISUPCO.GT.1) RETURN
  85. *
  86. *    VERIFICATION DU LIEU SUPPORT DU MCHAML DE DEFORMATIONS
  87. *
  88.       CALL QUESUP(IPMODL,IPCHED,5,0,ISUPDE,IRETDE)
  89.       IF (ISUPDE.GT.1) RETURN
  90. *
  91. *     ACTIVATION DU MODELE
  92. *
  93.       MMODEL=IPMODL
  94.       SEGACT MMODEL
  95.       NSOUS=KMODEL(/1)
  96. *
  97.       KEL22 = 0
  98.       DO ISOUS=1,NSOUS
  99.         IMODEL=KMODEL(ISOUS)
  100.         SEGACT,IMODEL
  101.         IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22+1
  102.       ENDDO
  103. *
  104. *     CREATION DU CHAMELEM RESULTAT
  105. *
  106.       N1=NSOUS-KEL22
  107.       N3=6
  108.       L1=8
  109.       SEGINI MCHELM
  110.       TITCHE='SCALAIRE'
  111.       IFOCHE=IFO1
  112. *
  113. *     DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
  114. *
  115.       isouss=0
  116.       DO 200 ISOUS=1,NSOUS
  117. *
  118. *        QUELQUES INITIALISATIONS
  119. *
  120.          IMODEL=KMODEL(ISOUS)
  121. C*       SEGACT IMODEL
  122.  
  123.          MELE=NEFMOD
  124.          if((MELE.EQ.22).OR.(MELE.EQ.259)) go to 200
  125.  
  126.          MOSTRS = 0
  127.          MODEFO = 0
  128.          IVADEF = 0
  129.          IVASTR = 0
  130.          IPMINT = 0
  131.          lsupco=.false.
  132.          lsupde=.false.
  133. *
  134.          IPMAIL=IMAMOD
  135.          CONM  =CONMOD
  136. *
  137. *        CREATION DU TABLEAU INFO
  138. *
  139.          CALL IDENT (IPMAIL,CONM,IPCHEC,IPCHED,INFOS,IRTD)
  140.          IF (IRTD.EQ.0) GOTO 9990
  141. *
  142. *        INFORMATION SUR L'ELEMENT FINI
  143. *
  144. *         CALL ELQUOI (MELE,0,5,IPINF,IMODEL)
  145. *         IF (IERR.NE.0) GOTO 9990
  146.          MFR=INFELE(13)
  147.          IPPORE=0
  148.          IF(MFR.EQ.33) IPPORE=NBNNE(NUMGEO(MELE))
  149. *         MINTE=INFELE(11)
  150. *   on saute les sous modeles n'ayant pas de fonctions de forme. Ex: contact
  151.          if (infmod(/1).lt.7) goto 200
  152.          minte=infmod(7)
  153.          if (minte.eq.0) goto 200
  154.          isouss=isouss+1
  155.  
  156.          IPMINT=MINTE
  157.          SEGACT,MINTE
  158. *
  159.          IMACHE(ISOUSs)=IPMAIL
  160.          CONCHE(ISOUSs)=CONMOD
  161. *
  162.          INFCHE(ISOUSs,1)=0
  163.          INFCHE(ISOUSs,2)=0
  164.          INFCHE(ISOUSs,3)=NHRM
  165.          INFCHE(ISOUSs,4)=MINTE
  166.          INFCHE(ISOUSs,5)=0
  167.          INFCHE(ISOUSs,6)=5
  168. *
  169. *        RECHERCHE DES NOMS DE COMPOSANTES
  170. *
  171.          NBTYPE=1
  172.          SEGINI NOTYPE
  173.          TYPE(1)='REAL*8'
  174.          MOTYPE=NOTYPE
  175. *
  176.          if(lnomid(4).ne.0) then
  177.           nomid=lnomid(4)
  178.           segact nomid
  179.           mostrs=nomid
  180.           nstr=lesobl(/2)
  181.           nfac=lesfac(/2)
  182.          else
  183.           lsupco=.true.
  184.           CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  185.           nomid=mostrs
  186.          endif
  187. *
  188.             CALL KOMCHA(IPCHEC,IPMAIL,CONM,MOSTRS,
  189.      1                           MOTYPE,1,INFOS,3,IVASTR)
  190.             IF (IERR.NE.0) THEN
  191.                 SEGSUP NOTYPE
  192.                 GOTO 9991
  193.             ENDIF
  194.             IF(ISUPCO.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,
  195.      &                     MOSTRS,MELE)
  196. *
  197.          if(lnomid(5) .ne.0) then
  198.           nomid=lnomid(5)
  199.           segact nomid
  200.           ndef=lesobl(/2)
  201.           modefo=nomid
  202.          else
  203.           lsupde=.true.
  204.           CALL IDDEFO(IMODEL,IFOUR,MODEFO,NDEF,NFAC)
  205.           nomid=modefo
  206.          endif
  207.             CALL KOMCHA(IPCHED,IPMAIL,CONM,MODEFO,MOTYPE,
  208.      1                                     1,INFOS,3,IVADEF)
  209.             SEGSUP NOTYPE
  210.             IF (IERR.NE.0) GOTO 9992
  211.             IF(ISUPDE.EQ.1)CALL VALCHE(IVADEF,NDEF,IPMINT,IPPORE,
  212.      &                     MODEFO,MELE)
  213. *
  214. *        RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  215. *
  216.          NSPTEL=0
  217.          NSEL  =0
  218.          MPTVAL=IVASTR
  219.          DO 1 ICOMP=1,NSTR
  220.             MELVAL=IVAL(ICOMP)
  221.             NSPTEL=MAX(NSPTEL,VELCHE(/1))
  222.             NSEL  =MAX(NSEL  ,VELCHE(/2))
  223.  1       CONTINUE
  224. *
  225.          NDPTEL=0
  226.          NDEL  =0
  227.          MPTVAL=IVADEF
  228.          DO 2 ICOMP=1,NDEF
  229.             MELVAL=IVAL(ICOMP)
  230.             NDPTEL=MAX(NDPTEL,VELCHE(/1))
  231.             NDEL  =MAX(NDEL  ,VELCHE(/2))
  232.  2       CONTINUE
  233. *
  234.          N1PTEL=MAX(NSPTEL,NDPTEL)
  235.          N1EL  =MAX(NSEL  ,NDEL  )
  236.          N2PTEL=0
  237.          N2EL  =0
  238. *
  239.          N2=1
  240.          SEGINI MCHAML
  241.          ICHAML(ISOUSs)=MCHAML
  242.          NOMCHE(1)='SCAL'
  243.          TYPCHE(1)='REAL*8'
  244.          SEGINI MELVAL
  245.          IELVAL(1)=MELVAL
  246.          IPMELV=MELVAL
  247. *
  248.          DO 310 IGAU=1,N1PTEL
  249.            DO 310 IB=1,N1EL
  250.               r_z=0.D0
  251. *
  252.               DO 366 ICOMP=1,NDEF
  253.                  MPTVAL=IVASTR
  254.                  MELVAL=IVAL(ICOMP)
  255.                  IGMN=MIN(IGAU,VELCHE(/1))
  256.                  IBMN=MIN(IB  ,VELCHE(/2))
  257.                  XTT1=VELCHE(IGMN,IBMN)
  258. *
  259.                  MPTVAL=IVADEF
  260.                  MELVAL=IVAL(ICOMP)
  261.                  IGMN=MIN(IGAU,VELCHE(/1))
  262.                  IBMN=MIN(IB  ,VELCHE(/2))
  263.                  XTT2=VELCHE(IGMN,IBMN)
  264. *
  265.                  r_z = r_z + XTT1*XTT2
  266.   366         CONTINUE
  267.               MELVAL=IPMELV
  268.               VELCHE(IGAU,IB)=r_z
  269.   310    CONTINUE
  270. *
  271. *        DESACTIVATION PROPRE A LA GEOMETRIE ISOUS
  272. *
  273.          MELVAL=IPMELV
  274.  9992   CONTINUE
  275.          NOMID=MODEFO
  276.          if(lsupde)SEGSUP NOMID
  277.          IF(ISUPDE.EQ.1)THEN
  278.             CALL DTMVAL(IVADEF,3)
  279.          ELSE
  280.             CALL DTMVAL(IVADEF,1)
  281.          ENDIF
  282.  9991   CONTINUE
  283.          NOMID=MOSTRS
  284.          if(lsupco)SEGSUP NOMID
  285.          IF(ISUPCO.EQ.1)THEN
  286.             CALL DTMVAL(IVASTR,3)
  287.          ELSE
  288.             CALL DTMVAL(IVASTR,1)
  289.          ENDIF
  290.  9990   CONTINUE
  291. *
  292. *     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  293.          IF (IERR.NE.0) THEN
  294.            SEGSUP MCHELM
  295.            IPCHR = 0
  296.            GOTO 999
  297.          ENDIF
  298.  
  299.   200 CONTINUE
  300.       IF (n1.ne.isouss) then
  301.        n1 = isouss
  302.        segadj mchelm
  303.       endif
  304. * Fin du sous-programme
  305.       IPCHR=MCHELM
  306. *
  307.  999  CONTINUE
  308.       END
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales