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

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