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

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