Télécharger la plaquette Cast3M


fr en

Télécharger kpres.eso

Retour à la liste

Numérotation des lignes : 

kpres

  1. C KPRES     SOURCE    CB215821  24/04/12    21:16:33     11897          
  2.       SUBROUTINE KPRES(IPMODL,IPCHPO,ICHA,ICONV,IFLAM,IASYM,IPRIG,IRET)
  3. C_______________________________________________________________________
  4. C
  5. C
  6. C                                         99
  7. C     Entrees:
  8. C     ________
  9. C
  10. C       IPMODL  Pointeur sur un MMODEL
  11. C       IPCHPO  Pointeur sur un MCHAML ou CHPOINT de PRESSION
  12. C
  13. C       ICHA   Flag : =1 IPCHPO est un pointeur sur un MCHAML
  14. C                     =0 IPCHPO est un pointeur sur un CHPOINT
  15. C
  16. C       ICONV   Flag de conversion
  17. C       IFLAM   Flag de flambage
  18. C
  19. C     Sorties:
  20. C     ________
  21. C
  22. C       IPRIG  Pointeur sur un objet RIGIDITE
  23. C       IRET    Flag de retour
  24. C
  25. C       CODE COMBESCURE JANV 87
  26. C
  27. C       Passage aux nouveaux CHAMELEMs par P.DOWLATYARI le 5/04/91
  28. C
  29. C
  30. C_______________________________________________________________________
  31. C
  32.       IMPLICIT INTEGER(I-N)
  33.       IMPLICIT REAL*8(A-H,O-Z)
  34. *
  35. -INC CCHAMP
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC SMRIGID
  40. -INC SMCHAML
  41. -INC SMELEME
  42. -INC SMCOORD
  43. -INC SMINTE
  44. -INC SMMODEL
  45. -INC SMCHPOI
  46. C
  47.       SEGMENT WRK1
  48.        REAL*8 REL(LRE,LRE) ,XE(3,NBBB)
  49.       ENDSEGMENT
  50. *
  51.       SEGMENT WRK2
  52.        REAL*8 SHPWRK(6,NBNO)
  53.       ENDSEGMENT
  54. *
  55.       SEGMENT WRK3
  56.        REAL*8 WORK(LW)
  57.       ENDSEGMENT
  58. *
  59.       SEGMENT WRK4
  60.        REAL*8 BPSS(3,3) ,XEL(3,NBBB)
  61.       ENDSEGMENT
  62.       segment wrk7
  63.          real*8 propel(2),d(1),work1(1),out(1)
  64.       endsegment
  65.       segment icpr (nbpts)
  66. *
  67.       SEGMENT MPTVAL
  68.         INTEGER IPOS(NS)    ,NSOF(NS)
  69.         INTEGER      IVAL(NCOSOU)
  70.         CHARACTER*16 TYVAL(NCOSOU)
  71.       ENDSEGMENT
  72. *
  73.       PARAMETER ( NINF=3 )
  74.       INTEGER INFOS(NINF)
  75.       LOGICAL lsupfo,lsupdp
  76. *
  77.       SEGMENT LIMODL(0)
  78. *
  79.       IRET=1
  80.       IVAPR=0
  81. *
  82. *     CHPOINT DE PRESSION ---> CHAMELEM AUX NOEUDS
  83. *
  84.       IF(ICHA.EQ.0)THEN
  85.          CALL CHAME1(0,IPMODL,IPCHPO,' ',IPCHE0,1)
  86.          IF (IERR.NE.0) RETURN
  87.          CALL REDUAF(IPCHE0,IPMODL,IPCHE1,0,IR,KER)
  88.          IF(IR   .NE. 1) CALL ERREUR(KER)
  89.          IF(IERR .NE. 0) RETURN
  90.       ELSE
  91.          IPCHE1=IPCHPO
  92.       ENDIF
  93.       MCHEL1=IPCHE1
  94.       SEGACT,MCHEL1
  95.       NBMAIC=MCHEL1.IMACHE(/1)
  96.       IF (NBMAIC.EQ.0) THEN
  97.         SEGDES,MCHEL1
  98.         IRET=0
  99.         CALL ERREUR(472)
  100.         RETURN
  101.       ENDIF
  102. C_______________________________________________________________________
  103. C
  104. C     ACTIVATION DU MODELE
  105. C_______________________________________________________________________
  106. C
  107.       MMODEL=IPMODL
  108.       SEGACT MMODEL
  109.       NSOUS=KMODEL(/1)
  110. C
  111. C     RECUPERATION DES MODELES
  112. C
  113.       SEGINI,LIMODL
  114.       DO 100 ISOUS=1,NSOUS
  115.         IMODEL=KMODEL(ISOUS)
  116.         SEGACT, IMODEL
  117.         IF(FORMOD(1).EQ.'MECANIQUE'.OR.(FORMOD(1).EQ.'CHARGEMENT'.AND.
  118.      &     MATMOD(1).EQ.'PRESSION')) THEN
  119.           LIMODL(**)=IMODEL
  120.         ELSE
  121.           SEGDES,IMODEL
  122.         ENDIF
  123.  100  CONTINUE
  124. C
  125.       NSOUS = LIMODL(/1)
  126.       IF (NSOUS.LE.0) THEN
  127.         SEGDES, MMODEL
  128.         SEGSUP, LIMODL
  129.         IF (ICHA.EQ.0) THEN 
  130.           CALL DTCHAM(MCHEL1)
  131.         ELSE
  132.           SEGDES,MCHEL1
  133.         ENDIF
  134.         CALL ERREUR(610)
  135.         RETURN
  136.       ENDIF
  137. *
  138. * verif si element shb8 d'avoir recu un chpoint de pression
  139. *
  140.       if(icha.eq.1) then
  141.         nsous=kmodel(/1)
  142.         do io=1,nsous
  143.          imodel=kmodel(io)
  144.          segact imodel
  145.           if(nefmod.eq.260) then
  146.            call erreur(1007)
  147.            return
  148.           endif
  149.         enddo
  150.       endif
  151. C
  152. C
  153. C     INITIALISATION DU CHAPEAU DE L OBJET RIGIDITE
  154. C
  155.       NRIGE=7
  156.       NRIGEL=NSOUS
  157.       SEGINI MRIGID
  158.       IPRIG=MRIGID
  159.       ICHOLE=0
  160.       IMGEO1=0
  161.       IMGEO2=0
  162.       IFORIG=IFOUR
  163.       IF (IFLAM.NE.0) THEN
  164.        MTYMAT='MASSE'
  165.       ELSE
  166.        MTYMAT='RIGIDITE'
  167.       ENDIF
  168. C
  169.       DO 140 ISOUS=1,NSOUS
  170.         IRIGEL(4,ISOUS)=0
  171.         COERIG(ISOUS)=1.D0
  172.   140 CONTINUE
  173. C_______________________________________________________________________
  174. C
  175. C      BOUCLE SUR LES SOUS ZONES DU MAILLAGE
  176. C_______________________________________________________________________
  177. C
  178.       DO 500 ISOUS=1,NSOUS
  179. C
  180. C       TRAITEMENT DU MODELE
  181. C
  182.         IMODEL=LIMODL(ISOUS)
  183.         MELE=NEFMOD
  184.         IPMAIL=IMAMOD
  185. C_______________________________________________________________________
  186. C
  187. C  INFOS. ELEMENT FINI
  188. C_______________________________________________________________________
  189. C
  190. *         CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  191.          IF ( IERR.NE.0 ) THEN
  192.            SEGDES IMODEL,MMODEL
  193.            SEGDES MCHEL1
  194.            IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
  195.            SEGSUP MRIGID
  196.            IRET=0
  197.            RETURN
  198.          ENDIF
  199. *         INFO=IPINF
  200.         LHOOK = INFELE(10)
  201.         LHOO2 = LHOOK*LHOOK
  202.         NSTRS = INFELE(16)
  203.         MFR   = INFELE(13)
  204.         LW    = INFELE(7)
  205.         IF(MELE.EQ.28)LW=600
  206.         NDDL  = INFELE(15)
  207.         LRE   = INFELE(9)
  208.         IPORE = INFELE(8)
  209.         LVAL  = (LRE*(LRE+1))/2
  210.         NHRM   = NIFOUR
  211. C
  212. C       CREATION DU TABLEAU INFOS
  213. C
  214.         INFOS(1)=0
  215.         INFOS(2)=0
  216.         INFOS(3)=NIFOUR
  217. C_______________________________________________________________________
  218. C
  219. C  INFOS. MAILLAGE
  220. C_______________________________________________________________________
  221. C
  222.         MELEME=IPMAIL
  223.         SEGACT MELEME
  224.         NBNN=NUM(/1)
  225.         NBELEM=NUM(/2)
  226. C_______________________________________________________________________
  227. C
  228. C  SEGMENTS D'INTEGRATION
  229. C_______________________________________________________________________
  230. C
  231. * Minte : 1er  segment d'integration, il existe pour tous les e.f.
  232. * Minte1: 2eme segment d'integration, uniquement pour certains e.f.
  233. *         en particulier pour Coq6 et Coq8
  234. * nbpg:nb de points de gauss = nbpgau du segment minte
  235. * iele:no d'element geometrique associe a l'e.f. mele
  236. * nbff:nb de fonctions de forme = nbno du segment minte
  237. *
  238.         NBPGAU= INFELE(  6)
  239.         IELE  = INFELE( 14)
  240.         ICARA = INFELE(  5)
  241. *        MINTE = INFELE(11)
  242.         MINTE=INFMOD(5)
  243.         MINTE1= INFMOD(8)
  244.         if(mele.ne.260)SEGACT MINTE
  245. C_______________________________________________________________________
  246. C
  247. C INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES
  248. C DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE
  249. C_______________________________________________________________________
  250. C
  251.         NLIGRP = INFELE(9)
  252.         NLIGRD = INFELE(9)
  253.         SEGINI DESCR
  254.         IPDESC=DESCR
  255.         if(lnomid(1).ne.0) then
  256.           nomid=lnomid(1)
  257.           segact nomid
  258.           modepl=nomid
  259.           ndepl=lesobl(/2)
  260.           ndum=lesfac(/2)
  261.           lsupdp=.false.
  262.         else
  263.           lsupdp=.true.
  264.           CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  265.         endif
  266.          if(lnomid(2).ne.0) then
  267.            nomid=lnomid(2)
  268.           segact nomid
  269.           moforc=nomid
  270.           nforc=lesobl(/2)
  271.           lsupfo=.false.
  272.         else
  273.          lsupfo=.true.
  274.          CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  275.         endif
  276. *
  277.         IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  278.           CALL ERREUR(5)
  279.           SEGSUP DESCR,MRIGID
  280.           SEGDES MCHEL1
  281.           IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
  282.           SEGDES MMODEL,MELEME,MINTE
  283.           SEGDES IMODEL
  284.           IRET=0
  285.           RETURN
  286.         ENDIF
  287. *
  288. *       REMPLISSAGE DU SEGMENT DESCRIPTEUR
  289. *
  290.         IDDL=1
  291.         NCOMP=NDEPL
  292.         NBNNS=NBNN
  293.         NOMID=MODEPL
  294.         SEGACT NOMID
  295.         NOMID=MOFORC
  296.         SEGACT NOMID
  297.         IF (MFR.EQ.33) NCOMP=NDEPL-1
  298.         IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
  299.         DO 1004 INOEUD=1,NBNNS
  300.           DO 1005 ICOMP=1,NCOMP
  301.             NOMID=MODEPL
  302.             LISINC(IDDL)=LESOBL(ICOMP)
  303.             NOMID=MOFORC
  304.             LISDUA(IDDL)=LESOBL(ICOMP)
  305.             NOELEP(IDDL)=INOEUD
  306.             NOELED(IDDL)=INOEUD
  307.             IDDL=IDDL+1
  308.  1005     CONTINUE
  309.  1004   CONTINUE
  310.         NOMID=MODEPL
  311.         if(lsupdp)SEGSUP NOMID
  312.         NOMID=MOFORC
  313.         if(lsupfo)SEGSUP NOMID
  314. *
  315. *          CAS DES MILIEUX POREUX
  316. *
  317. *          IF (MFR.EQ.33) THEN
  318. *            DO 1104 INOEUD=1,NBSOM(IELE)
  319. *              NOMID=MODEPL
  320. *              LISINC(IDDL)=LESOBL(NDEPL)
  321. *              NOMID=MOFORC
  322. *              LISDUA(IDDL)=LESOBL(NDEPL)
  323. *              NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  324. *              NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  325. *              IDDL=IDDL+1
  326. *1104        CONTINUE
  327. *          ENDIF
  328. *
  329. *          CAS DES ELEMENT RACCORD
  330. *
  331.         IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  332.           CALL IDPRIM(IMODEL,MFR+1000,MODEPL,NDEPL,NDUM)
  333.           CALL IDDUAL(IMODEL,MFR+1000,MOFORC,NFORC,NDUM)
  334.           DO 1106 INOEUD=NBNNS+1,NBNN
  335.             DO 1107 ICOMP=1,NDEPL
  336.               NOMID=MODEPL
  337.               LISINC(IDDL)=LESOBL(ICOMP)
  338.               NOMID=MOFORC
  339.               LISDUA(IDDL)=LESOBL(ICOMP)
  340.               NOELEP(IDDL)=INOEUD
  341.               NOELED(IDDL)=INOEUD
  342.               IDDL=IDDL+1
  343. 1107        CONTINUE
  344. 1106      CONTINUE
  345.           NOMID=MODEPL
  346.           SEGSUP NOMID
  347.           NOMID=MOFORC
  348.           SEGSUP NOMID
  349.         ENDIF
  350.  
  351.         SEGDES DESCR
  352. C_______________________________________________________________________
  353. C
  354. C INITIALISATION DU SEGMENT IMATRI,
  355. C CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES
  356. C_______________________________________________________________________
  357. C
  358. * NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE
  359.         NELRIG = NBELEM
  360.         SEGINI xMATRI
  361. C_______________________________________________________________________
  362. C
  363. C  TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID
  364. C_______________________________________________________________________
  365. C
  366.         IRIGEL(1,ISOUS)=IPMAIL
  367.         IRIGEL(2,ISOUS)=0
  368.         IRIGEL(3,ISOUS)=IPDESC
  369.         IRIGEL(4,ISOUS)=xMATRI
  370.         IRIGEL(5,ISOUS)=NIFOUR
  371.         IF (IASYM .EQ. 0) THEN
  372.           IRIGEL(7, ISOUS) = 0
  373.           xmatri.symre=0
  374.         ELSE
  375.           IRIGEL(7, ISOUS) = 2
  376.           xmatri.symre=2
  377.         ENDIF
  378. C_______________________________________________________________________
  379. C
  380. C VALEURS DE PRESSION
  381. C_______________________________________________________________________
  382. C
  383.         CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
  384.         MCHAM1=MCHEL1.ICHAML(IM)
  385.         SEGACT MCHAM1
  386.         IVAPR=MCHAM1.IELVAL(1)
  387.         SEGDES MCHAM1
  388.         MELVAL=IVAPR
  389.         IF(IVAPR.NE.0)SEGACT MELVAL
  390. *
  391. C=======================================================================
  392. C     NUMERO DES ETIQUETTES      :
  393. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  394. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  395. C     5  CONTINUE
  396. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  397. C     44 CONTINUE
  398. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  399. C=======================================================================
  400.  
  401.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  402.      1      99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  403.      2      41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
  404.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  405.      4      99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
  406. C
  407.  
  408.       if(mele.eq.260) go to 1260
  409.       GOTO 99
  410.   27  CONTINUE
  411. C_______________________________________________________________________
  412. C
  413. C                   ELEMENT COQ3
  414. C_______________________________________________________________________
  415. C
  416.       NBBB=NBNN
  417.       SEGINI WRK1,WRK3,WRK4
  418.       DO 3027  IB=1,NBELEM
  419. C
  420. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  421. C
  422.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  423.       CALL ZERO(REL,LRE,LRE)
  424. C
  425. C     ON CHERCHE LES PRESSIONS
  426. C
  427.       PRESS=0.D0
  428.       IF(MELVAL.NE.0)THEN
  429.         IBMN=MIN(IB  ,VELCHE(/2))
  430.         DO 4027 IGAU=1,NBNN
  431.           IGMN=MIN(IGAU,VELCHE(/1))
  432.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  433.  4027   CONTINUE
  434.         PRESS=PRESS/NBNN
  435.       ENDIF
  436. C
  437. C         ON CALCULE K(P)
  438. C
  439. *      SEGINI XMATRI
  440.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  441. *      SEGINI XMATRI
  442. *      IMATTT(IB)=XMATRI
  443. C
  444. C     REMPLISSAGE DE XMATRI
  445. C
  446. *      CALL REMPMC(REL,LRE,RE(1,1,ib))
  447. *      SEGDES XMATRI
  448.  3027 CONTINUE
  449.       SEGDES xMATRI
  450.       SEGSUP WRK1,WRK3,WRK4
  451.       GOTO 510
  452. C_______________________________________________________________________
  453. C
  454. C     ELEMENT DKT    POUR L INSTANT = COQ3
  455. C_______________________________________________________________________
  456. C
  457.   28  CONTINUE
  458.       NBBB=NBNN
  459.       SEGINI WRK1,WRK3,WRK4
  460.       DO 3028  IB=1,NBELEM
  461. C
  462. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  463. C
  464.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  465. C
  466.       CALL ZERO(REL,LRE,LRE)
  467. C
  468. C     ON CHERCHE LES PRESSIONS
  469. C
  470.       PRESS=0.D0
  471.       IF(MELVAL.NE.0)THEN
  472.         IBMN=MIN(IB  ,VELCHE(/2))
  473.         DO 4028 IGAU=1,NBNN
  474.           IGMN=MIN(IGAU,VELCHE(/1))
  475.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  476.  4028   CONTINUE
  477.         PRESS=PRESS/NBNN
  478.       ENDIF
  479. C
  480. C         ON CALCULE K(P)
  481. C
  482. *      SEGINI XMATRI
  483.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  484. *      SEGINI XMATRI
  485. *      IMATTT(IB)=XMATRI
  486. C
  487. C     REMPLISSAGE DE XMATRI
  488. C
  489. *      CALL REMPMC(REL,LRE,RE)
  490. *      SEGDES XMATRI
  491.  3028 CONTINUE
  492.       SEGDES xMATRI
  493.       SEGSUP WRK1,WRK3,WRK4
  494.       GOTO 510
  495. C_______________________________________________________________________
  496. C
  497. C  ELEMENT COQ8  NON ENCORE BRANCHE
  498. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  499. C_______________________________________________________________________
  500. C
  501.  41   CONTINUE
  502.       NBBB=NBNN
  503.       SEGINI WRK1,WRK3
  504.       DO 3041 IB=1,NBELEM
  505. C
  506. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  507. C
  508.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  509. C
  510.       CALL ZERO(REL,LRE,LRE)
  511. C
  512. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  513. C
  514.       PRESS=0.D0
  515.       IF(MELVAL.NE.0)THEN
  516.         IBMN=MIN(IB  ,VELCHE(/2))
  517.         DO 4041 IGAU=1,NBNN
  518.           IGMN=MIN(IGAU,VELCHE(/1))
  519.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  520.  4041   CONTINUE
  521.         PRESS=PRESS/NBNN
  522.       ENDIF
  523. *      IE=0
  524. *       DO 7041 IGAU=1,NBNN
  525. *         IE=IE+1
  526. *         IF (MELVAL.NE.0) THEN
  527. *           IGMN=MIN(IGAU,VELCHE(/1))
  528. *           IBMN=MIN(IB  ,VELCHE(/2))
  529. *           WORK(IE)=VELCHE(IGMN,IBMN)
  530. *         ELSE
  531. *           WORK(IE)=0.D0
  532. *         ENDIF
  533. * 7041  CONTINUE
  534. C
  535. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  536. C
  537. *      SEGINI XMATRI
  538.       CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
  539. C
  540. C  REMPLISSAGE DE XMATRI
  541. C
  542. *      SEGINI XMATRI
  543. *      IMATTT(IB)=XMATRI
  544. *      CALL REMPMC(REL,LRE,RE)
  545. *      SEGDES XMATRI
  546.  3041 CONTINUE
  547.       SEGDES xMATRI
  548.       SEGSUP WRK1,WRK3
  549.       GO TO 510
  550. C_______________________________________________________________________
  551. C
  552. C     ELEMENT COQ2
  553. C_______________________________________________________________________
  554. C
  555.    44 CONTINUE
  556. *
  557. *  AM 01/09/94  PETIT TEST SUR IFOUR CAR NE FONCTIONNE
  558. *  QU'EN SERIE DE FOURIER
  559. *
  560.       IF(IFOUR.NE.1) GO TO 99
  561.  
  562. *  BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
  563.       IF(IASYM.NE.0) THEN
  564.         write(ioimp,*) 'L option de calcul ASYMetrique ',
  565.      &  'n est pas disponible avec les coq2 !'
  566.         call ERREUR(19)
  567.         goto 9990
  568.       ENDIF
  569.  
  570.       NBBB=NBNN
  571.       SEGINI WRK1,WRK3,WRK4
  572.       DO 3044 IB=1,NBELEM
  573. C
  574. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  575. C
  576.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  577.       CALL ZERO(REL,LRE,LRE)
  578. C
  579. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  580. C
  581.       WORK(1)=0.D0
  582.  
  583.       IF(MELVAL.NE.0)THEN
  584.         IBMN=MIN(IB  ,VELCHE(/2))
  585.         DO 1344 IGAU=1,NBNN
  586.           IGMN=MIN(IGAU,VELCHE(/1))
  587.           WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
  588.  1344   CONTINUE
  589.         WORK(1)=WORK(1)/NBNN
  590.       ENDIF
  591. C
  592. C     APPEL A COQUE2 KP
  593. C
  594.       AN=NHRM
  595.       CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
  596.      1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
  597.      2 WORK(157),WORK(221),WORK(285))
  598. C
  599. C     REMPLISSAGE DE XMATRI
  600. C
  601. *      SEGINI XMATRI
  602. *      IMATTT(IB)=XMATRI
  603.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  604. *      SEGDES XMATRI
  605.  3044 CONTINUE
  606.       SEGDES xMATRI
  607.       SEGSUP WRK1,WRK3,WRK4
  608.       GOTO 510
  609. C_______________________________________________________________________
  610. C
  611. C     ELEMENT COQ4   NON ENCORE BRANCHE
  612. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  613. C_______________________________________________________________________
  614. C
  615.    49 CONTINUE
  616.       NBBB=NBNN
  617.       SEGINI WRK1,WRK3,WRK4
  618.       DO 3049 IB=1,NBELEM
  619. C
  620. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  621. C
  622.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  623. C
  624.       CALL ZERO(REL,LRE,LRE)
  625. C
  626. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  627. C
  628.       PRESS=0.D0
  629.       IF(MELVAL.NE.0)THEN
  630.         IBMN=MIN(IB  ,VELCHE(/2))
  631.         DO 4049 IGAU=1,NBNN
  632.           IGMN=MIN(IGAU,VELCHE(/1))
  633.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  634.  4049   CONTINUE
  635.         PRESS=PRESS/NBNN
  636.       ENDIF
  637. *       IE=0
  638. *       DO 5049 IGAU=1,NBNN
  639. *         IE=IE+1
  640. *         IF (MELVAL.NE.0) THEN
  641. *           IGMN=MIN(IGAU,VELCHE(/1))
  642. *           IBMN=MIN(IB  ,VELCHE(/2))
  643. *           WORK(IE)=VELCHE(IGMN,IBMN)
  644. *         ELSE
  645. *           WORK(IE)=0.D0
  646. *         ENDIF
  647. * 5049  CONTINUE
  648. C
  649. C     APPEL A COQUE4 KSIGMA...
  650. C
  651.       AN=NHRM
  652. *      SEGINI XMATRI
  653. *      CALL KPCOQ4(XE,PRESS,REL,IASYM)
  654.       CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
  655. C
  656. C     REMPLISSAGE DE XMATRI
  657. C
  658. *      SEGINI XMATRI
  659. *      IMATTT(IB)=XMATRI
  660. *      CALL REMPMC(REL,LRE,RE)
  661. *      SEGDES XMATRI
  662.  3049 CONTINUE
  663.       SEGDES xMATRI
  664.       SEGSUP WRK1,WRK3,WRK4
  665.       GOTO 510
  666. C_______________________________________________________________________
  667. C
  668. C    element SHB8
  669. C_______________________________________________________________________
  670. C
  671.  1260 continue
  672. *
  673.       NBBB=NBNN
  674.       SEGINI WRK1,wrk7
  675. *  reperage du chpoint de pression
  676.       segini icpr
  677.       mchpoi=ipchpO
  678.       segact mchpoi
  679.       ino=0
  680.       if(ipchp(/1).ne.1) then
  681.         call erreur(19)
  682.         return
  683.       endif
  684.       msoupo=ipchp(1)
  685.       segact msoupo
  686.       if(noharm(/1).ne.1)then
  687.          call erreur(180)
  688.          return
  689.       endif
  690.       meleme=igeoc
  691.       segact meleme
  692.       do ia=1,num(/2)
  693.         ib=num(1,ia)
  694.         if(icpr(ib).eq.0) then
  695.           ino=ino+1
  696.           icpr(ib)=ino
  697.         endif
  698.       enddo
  699.       segdes meleme
  700.       mpoval=ipoval
  701.       segact mpoval
  702. * on cherche si surf interne ou externe
  703.       meleme=ipmail
  704.       if(lisref(/1).ne.2) then
  705.          call erreur (1004)
  706.          return
  707.       endif
  708.       isur=0
  709.       do icas=1,2
  710.         ipt3=lisref(icas)
  711.         segact ipt3
  712.         do ia=1,ipt3.num(/2)
  713.           do ic=1,4
  714.             ib=ipt3.num(ic,ia)
  715.             if(icpr(ib).eq.0) go to 2260
  716.           enddo
  717.         enddo
  718.         isur=icas
  719.         go to 3260
  720.  2260  continue
  721.        segdes ipt3
  722.       enddo
  723.       call erreur(286)
  724.       return
  725. 3260  continue
  726.       propel(2)=isur
  727.  
  728.       DO 4260 IB=1,NBELEM
  729. C
  730. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  731. C
  732.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  733.       CALL ZERO(REL,LRE,LRE)
  734. C
  735. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  736. C
  737.       pre=0.d0
  738.       do ia=1,4
  739.        ibb=ipt3.num(ia,ib)
  740.        pre=pre+vpocha(icpr(ibb),1)/4
  741.       enddo
  742.       propel(1)=pre
  743.  
  744. C
  745. C     APPEL A shb8 KP
  746. C
  747.       call shb8(10,xe,D,propel,work1,rel,out)
  748. C
  749. C     REMPLISSAGE DE XMATRI
  750. C
  751. *      SEGINI XMATRI
  752. *      IMATTT(IB)=XMATRI
  753.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  754. *      SEGDES XMATRI
  755.  4260 CONTINUE
  756.       SEGDES xMATRI
  757.       SEGSUP WRK1,WRK7
  758.       segsup icpr
  759.       segdes mpoval
  760.       GOTO 510
  761. C_______________________________________________________________________
  762. C
  763. C  ELEMENT COQ6  NON ENCORE BRANCHE
  764. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  765. C_______________________________________________________________________
  766. C
  767.  56   CONTINUE
  768.       NBBB=NBNN
  769.       SEGINI WRK1,WRK3
  770.       DO 3056 IB=1,NBELEM
  771. C
  772. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  773. C
  774.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  775. C
  776.       CALL ZERO(REL,LRE,LRE)
  777. C
  778. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  779. C
  780.       PRESS=0.D0
  781.       IF(MELVAL.NE.0)THEN
  782.         IBMN=MIN(IB  ,VELCHE(/2))
  783.         DO 4056 IGAU=1,NBNN
  784.           IGMN=MIN(IGAU,VELCHE(/1))
  785.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  786.  4056   CONTINUE
  787.         PRESS=PRESS/NBNN
  788.       ENDIF
  789. *      IE= 0
  790. *       DO 7056 IGAU=1,NBNN
  791. *         IE=IE+1
  792. *         IF (MELVAL.NE.0) THEN
  793. *           IGMN=MIN(IGAU,VELCHE(/1))
  794. *           IBMN=MIN(IB  ,VELCHE(/2))
  795. *           WORK(IE)=VELCHE(IGMN,IBMN)
  796. *         ELSE
  797. *           WORK(IE)=0.D0
  798. *         ENDIF
  799. * 7056  CONTINUE
  800. C
  801. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  802. C
  803. *      SEGINI XMATRI
  804.       CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
  805. C
  806. C  REMPLISSAGE DE XMATRI
  807. C
  808. *      SEGINI XMATRI
  809. *      IMATTT(IB)=XMATRI
  810. *      CALL REMPMC(REL,LRE,RE)
  811. *      SEGDES XMATRI
  812.  3056 CONTINUE
  813.       SEGDES xMATRI
  814.       SEGSUP WRK1,WRK3
  815.       GO TO 510
  816. C_______________________________________________________________________
  817. C
  818. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  819. C_______________________________________________________________________
  820. C
  821.   510 CONTINUE
  822.       SEGDES MELEME
  823.       SEGDES IMODEL
  824.       IF (IVAPR.NE.0) SEGDES MELVAL
  825. C
  826.       if(mele.ne.260)SEGDES MINTE
  827. C      SEGSUP INFO
  828. C_______________________________________________________________________
  829. C
  830. C      FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
  831. C_______________________________________________________________________
  832. C
  833.   500 CONTINUE
  834. C
  835.       SEGDES MRIGID
  836.       SEGDES MMODEL
  837.       SEGDES MCHEL1
  838.       SEGSUP,LIMODL
  839.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  840.       RETURN
  841. C
  842. C_______________________________________________________________________
  843. C
  844. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  845. C_______________________________________________________________________
  846. C
  847. C     ELEMENT NON IMPLEMENTE
  848. C
  849.    99 CONTINUE
  850.       MOTERR(1:4)=NOMTP(MELE)
  851.       MOTERR(5:12)='KPRES   '
  852.       CALL ERREUR(86)
  853. C
  854.  9990 CONTINUE
  855.       IRET=0
  856.  
  857.       IF(IVAPR.NE.0)SEGDES MELVAL
  858. C
  859.       SEGSUP,LIMODL
  860.       SEGDES MELEME
  861.       SEGDES IMODEL
  862.       SEGSUP DESCR
  863.       SEGSUP xMATRI
  864. C
  865.       SEGDES MMODEL
  866.       SEGDES MCHEL1
  867.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  868.       SEGDES MINTE
  869. C      SEGSUP INFO
  870.       SEGSUP MRIGID
  871.       RETURN
  872.       END
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  
  880.  
  881.  
  882.  
  883.  
  884.  
  885.  
  886.  

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