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

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