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    PV090527  26/04/30    21:15:47     12529          
  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.         RIGREL=0
  347.         SEGINI xMATRI
  348. C_______________________________________________________________________
  349. C
  350. C  TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID
  351. C_______________________________________________________________________
  352. C
  353.         IRIGEL(1,ISOUS)=IPMAIL
  354.         IRIGEL(2,ISOUS)=0
  355.         IRIGEL(3,ISOUS)=IPDESC
  356.         IRIGEL(4,ISOUS)=xMATRI
  357.         IRIGEL(5,ISOUS)=NIFOUR
  358.         IF (IASYM .EQ. 0) THEN
  359.           IRIGEL(7, ISOUS) = 0
  360.           xmatri.symre=0
  361.         ELSE
  362.           IRIGEL(7, ISOUS) = 2
  363.           xmatri.symre=2
  364.         ENDIF
  365. C_______________________________________________________________________
  366. C
  367. C VALEURS DE PRESSION
  368. C_______________________________________________________________________
  369. C
  370.         CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
  371.         MCHAM1=MCHEL1.ICHAML(IM)
  372.         SEGACT MCHAM1
  373.         IVAPR=MCHAM1.IELVAL(1)
  374.         SEGDES MCHAM1
  375.         MELVAL=IVAPR
  376.         IF(IVAPR.NE.0)SEGACT MELVAL
  377. *
  378. C=======================================================================
  379. C     NUMERO DES ETIQUETTES      :
  380. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  381. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  382. C     5  CONTINUE
  383. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  384. C     44 CONTINUE
  385. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  386. C=======================================================================
  387.  
  388.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  389.      1      99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  390.      2      41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
  391.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  392.      4      99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
  393. C
  394.  
  395.       if(mele.eq.260) go to 1260
  396.       GOTO 99
  397.   27  CONTINUE
  398. C_______________________________________________________________________
  399. C
  400. C                   ELEMENT COQ3
  401. C_______________________________________________________________________
  402. C
  403.       NBBB=NBNN
  404.       SEGINI WRK1,WRK3,WRK4
  405.       DO 3027  IB=1,NBELEM
  406. C
  407. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  408. C
  409.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  410.       CALL ZERO(REL,LRE,LRE)
  411. C
  412. C     ON CHERCHE LES PRESSIONS
  413. C
  414.       PRESS=0.D0
  415.       IF(MELVAL.NE.0)THEN
  416.         IBMN=MIN(IB  ,VELCHE(/2))
  417.         DO 4027 IGAU=1,NBNN
  418.           IGMN=MIN(IGAU,VELCHE(/1))
  419.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  420.  4027   CONTINUE
  421.         PRESS=PRESS/NBNN
  422.       ENDIF
  423. C
  424. C         ON CALCULE K(P)
  425. C
  426. *      SEGINI XMATRI
  427.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  428. *      SEGINI XMATRI
  429. *      IMATTT(IB)=XMATRI
  430. C
  431. C     REMPLISSAGE DE XMATRI
  432. C
  433. *      CALL REMPMC(REL,LRE,RE(1,1,ib))
  434. *      SEGDES XMATRI
  435.  3027 CONTINUE
  436.       SEGDES xMATRI
  437.       SEGSUP WRK1,WRK3,WRK4
  438.       GOTO 510
  439. C_______________________________________________________________________
  440. C
  441. C     ELEMENT DKT    POUR L INSTANT = COQ3
  442. C_______________________________________________________________________
  443. C
  444.   28  CONTINUE
  445.       NBBB=NBNN
  446.       SEGINI WRK1,WRK3,WRK4
  447.       DO 3028  IB=1,NBELEM
  448. C
  449. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  450. C
  451.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  452. C
  453.       CALL ZERO(REL,LRE,LRE)
  454. C
  455. C     ON CHERCHE LES PRESSIONS
  456. C
  457.       PRESS=0.D0
  458.       IF(MELVAL.NE.0)THEN
  459.         IBMN=MIN(IB  ,VELCHE(/2))
  460.         DO 4028 IGAU=1,NBNN
  461.           IGMN=MIN(IGAU,VELCHE(/1))
  462.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  463.  4028   CONTINUE
  464.         PRESS=PRESS/NBNN
  465.       ENDIF
  466. C
  467. C         ON CALCULE K(P)
  468. C
  469. *      SEGINI XMATRI
  470.       CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  471. *      SEGINI XMATRI
  472. *      IMATTT(IB)=XMATRI
  473. C
  474. C     REMPLISSAGE DE XMATRI
  475. C
  476. *      CALL REMPMC(REL,LRE,RE)
  477. *      SEGDES XMATRI
  478.  3028 CONTINUE
  479.       SEGDES xMATRI
  480.       SEGSUP WRK1,WRK3,WRK4
  481.       GOTO 510
  482. C_______________________________________________________________________
  483. C
  484. C  ELEMENT COQ8  NON ENCORE BRANCHE
  485. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  486. C_______________________________________________________________________
  487. C
  488.  41   CONTINUE
  489.       NBBB=NBNN
  490.       SEGINI WRK1,WRK3
  491.       DO 3041 IB=1,NBELEM
  492. C
  493. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  494. C
  495.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  496. C
  497.       CALL ZERO(REL,LRE,LRE)
  498. C
  499. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  500. C
  501.       PRESS=0.D0
  502.       IF(MELVAL.NE.0)THEN
  503.         IBMN=MIN(IB  ,VELCHE(/2))
  504.         DO 4041 IGAU=1,NBNN
  505.           IGMN=MIN(IGAU,VELCHE(/1))
  506.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  507.  4041   CONTINUE
  508.         PRESS=PRESS/NBNN
  509.       ENDIF
  510. *      IE=0
  511. *       DO 7041 IGAU=1,NBNN
  512. *         IE=IE+1
  513. *         IF (MELVAL.NE.0) THEN
  514. *           IGMN=MIN(IGAU,VELCHE(/1))
  515. *           IBMN=MIN(IB  ,VELCHE(/2))
  516. *           WORK(IE)=VELCHE(IGMN,IBMN)
  517. *         ELSE
  518. *           WORK(IE)=0.D0
  519. *         ENDIF
  520. * 7041  CONTINUE
  521. C
  522. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  523. C
  524. *      SEGINI XMATRI
  525.       CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
  526. C
  527. C  REMPLISSAGE DE XMATRI
  528. C
  529. *      SEGINI XMATRI
  530. *      IMATTT(IB)=XMATRI
  531. *      CALL REMPMC(REL,LRE,RE)
  532. *      SEGDES XMATRI
  533.  3041 CONTINUE
  534.       SEGDES xMATRI
  535.       SEGSUP WRK1,WRK3
  536.       GO TO 510
  537. C_______________________________________________________________________
  538. C
  539. C     ELEMENT COQ2
  540. C_______________________________________________________________________
  541. C
  542.    44 CONTINUE
  543. *
  544. *  AM 01/09/94  PETIT TEST SUR IFOUR CAR NE FONCTIONNE
  545. *  QU'EN SERIE DE FOURIER
  546. *
  547.       IF(IFOUR.NE.1) GO TO 99
  548.  
  549. *  BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
  550.       IF(IASYM.NE.0) THEN
  551.         write(ioimp,*) 'L option de calcul ASYMetrique ',
  552.      &  'n est pas disponible avec les coq2 !'
  553.         call ERREUR(19)
  554.         goto 9990
  555.       ENDIF
  556.  
  557.       NBBB=NBNN
  558.       SEGINI WRK1,WRK3,WRK4
  559.       DO 3044 IB=1,NBELEM
  560. C
  561. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  562. C
  563.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  564.       CALL ZERO(REL,LRE,LRE)
  565. C
  566. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  567. C
  568.       WORK(1)=0.D0
  569.  
  570.       IF(MELVAL.NE.0)THEN
  571.         IBMN=MIN(IB  ,VELCHE(/2))
  572.         DO 1344 IGAU=1,NBNN
  573.           IGMN=MIN(IGAU,VELCHE(/1))
  574.           WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
  575.  1344   CONTINUE
  576.         WORK(1)=WORK(1)/NBNN
  577.       ENDIF
  578. C
  579. C     APPEL A COQUE2 KP
  580. C
  581.       AN=NHRM
  582.       CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
  583.      1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
  584.      2 WORK(157),WORK(221),WORK(285))
  585. C
  586. C     REMPLISSAGE DE XMATRI
  587. C
  588. *      SEGINI XMATRI
  589. *      IMATTT(IB)=XMATRI
  590.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  591. *      SEGDES XMATRI
  592.  3044 CONTINUE
  593.       SEGDES xMATRI
  594.       SEGSUP WRK1,WRK3,WRK4
  595.       GOTO 510
  596. C_______________________________________________________________________
  597. C
  598. C     ELEMENT COQ4   NON ENCORE BRANCHE
  599. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  600. C_______________________________________________________________________
  601. C
  602.    49 CONTINUE
  603.       NBBB=NBNN
  604.       SEGINI WRK1,WRK3,WRK4
  605.       DO 3049 IB=1,NBELEM
  606. C
  607. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  608. C
  609.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  610. C
  611.       CALL ZERO(REL,LRE,LRE)
  612. C
  613. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  614. C
  615.       PRESS=0.D0
  616.       IF(MELVAL.NE.0)THEN
  617.         IBMN=MIN(IB  ,VELCHE(/2))
  618.         DO 4049 IGAU=1,NBNN
  619.           IGMN=MIN(IGAU,VELCHE(/1))
  620.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  621.  4049   CONTINUE
  622.         PRESS=PRESS/NBNN
  623.       ENDIF
  624. *       IE=0
  625. *       DO 5049 IGAU=1,NBNN
  626. *         IE=IE+1
  627. *         IF (MELVAL.NE.0) THEN
  628. *           IGMN=MIN(IGAU,VELCHE(/1))
  629. *           IBMN=MIN(IB  ,VELCHE(/2))
  630. *           WORK(IE)=VELCHE(IGMN,IBMN)
  631. *         ELSE
  632. *           WORK(IE)=0.D0
  633. *         ENDIF
  634. * 5049  CONTINUE
  635. C
  636. C     APPEL A COQUE4 KSIGMA...
  637. C
  638.       AN=NHRM
  639. *      SEGINI XMATRI
  640. *      CALL KPCOQ4(XE,PRESS,REL,IASYM)
  641.       CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
  642. C
  643. C     REMPLISSAGE DE XMATRI
  644. C
  645. *      SEGINI XMATRI
  646. *      IMATTT(IB)=XMATRI
  647. *      CALL REMPMC(REL,LRE,RE)
  648. *      SEGDES XMATRI
  649.  3049 CONTINUE
  650.       SEGDES xMATRI
  651.       SEGSUP WRK1,WRK3,WRK4
  652.       GOTO 510
  653. C_______________________________________________________________________
  654. C
  655. C    element SHB8
  656. C_______________________________________________________________________
  657. C
  658.  1260 continue
  659. *
  660.       NBBB=NBNN
  661.       SEGINI WRK1,wrk7
  662. *  reperage du chpoint de pression
  663.       segini icpr
  664.       mchpoi=ipchpO
  665.       segact mchpoi
  666.       ino=0
  667.       if(ipchp(/1).ne.1) then
  668.         call erreur(19)
  669.         return
  670.       endif
  671.       msoupo=ipchp(1)
  672.       segact msoupo
  673.       if(noharm(/1).ne.1)then
  674.          call erreur(180)
  675.          return
  676.       endif
  677.       meleme=igeoc
  678.       segact meleme
  679.       do ia=1,num(/2)
  680.         ib=num(1,ia)
  681.         if(icpr(ib).eq.0) then
  682.           ino=ino+1
  683.           icpr(ib)=ino
  684.         endif
  685.       enddo
  686.       segdes meleme
  687.       mpoval=ipoval
  688.       segact mpoval
  689. * on cherche si surf interne ou externe
  690.       meleme=ipmail
  691.       if(lisref(/1).ne.2) then
  692.          call erreur (1004)
  693.          return
  694.       endif
  695.       isur=0
  696.       do icas=1,2
  697.         ipt3=lisref(icas)
  698.         segact ipt3
  699.         do ia=1,ipt3.num(/2)
  700.           do ic=1,4
  701.             ib=ipt3.num(ic,ia)
  702.             if(icpr(ib).eq.0) go to 2260
  703.           enddo
  704.         enddo
  705.         isur=icas
  706.         go to 3260
  707.  2260  continue
  708.        segdes ipt3
  709.       enddo
  710.       call erreur(286)
  711.       return
  712. 3260  continue
  713.       propel(2)=isur
  714.  
  715.       DO 4260 IB=1,NBELEM
  716. C
  717. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE  L ELEMENT IB
  718. C
  719.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  720.       CALL ZERO(REL,LRE,LRE)
  721. C
  722. C     ON CHERCHE LES PRESSIONS   ON LES MET DANS WORK...
  723. C
  724.       pre=0.d0
  725.       do ia=1,4
  726.        ibb=ipt3.num(ia,ib)
  727.        pre=pre+vpocha(icpr(ibb),1)/4
  728.       enddo
  729.       propel(1)=pre
  730.  
  731. C
  732. C     APPEL A shb8 KP
  733. C
  734.       call shb8(10,xe,D,propel,work1,rel,out)
  735. C
  736. C     REMPLISSAGE DE XMATRI
  737. C
  738. *      SEGINI XMATRI
  739. *      IMATTT(IB)=XMATRI
  740.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  741. *      SEGDES XMATRI
  742.  4260 CONTINUE
  743.       SEGDES xMATRI
  744.       SEGSUP WRK1,WRK7
  745.       segsup icpr
  746.       segdes mpoval
  747.       GOTO 510
  748. C_______________________________________________________________________
  749. C
  750. C  ELEMENT COQ6  NON ENCORE BRANCHE
  751. C  LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  752. C_______________________________________________________________________
  753. C
  754.  56   CONTINUE
  755.       NBBB=NBNN
  756.       SEGINI WRK1,WRK3
  757.       DO 3056 IB=1,NBELEM
  758. C
  759. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  760. C
  761.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  762. C
  763.       CALL ZERO(REL,LRE,LRE)
  764. C
  765. C  ON CHERCHE LES PRESSION    - ON LES MET DANS WORK
  766. C
  767.       PRESS=0.D0
  768.       IF(MELVAL.NE.0)THEN
  769.         IBMN=MIN(IB  ,VELCHE(/2))
  770.         DO 4056 IGAU=1,NBNN
  771.           IGMN=MIN(IGAU,VELCHE(/1))
  772.           PRESS=PRESS+VELCHE(IGMN,IBMN)
  773.  4056   CONTINUE
  774.         PRESS=PRESS/NBNN
  775.       ENDIF
  776. *      IE= 0
  777. *       DO 7056 IGAU=1,NBNN
  778. *         IE=IE+1
  779. *         IF (MELVAL.NE.0) THEN
  780. *           IGMN=MIN(IGAU,VELCHE(/1))
  781. *           IBMN=MIN(IB  ,VELCHE(/2))
  782. *           WORK(IE)=VELCHE(IGMN,IBMN)
  783. *         ELSE
  784. *           WORK(IE)=0.D0
  785. *         ENDIF
  786. * 7056  CONTINUE
  787. C
  788. C  ON CALCULE LA RIGIDITE GEOMETRIQUE
  789. C
  790. *      SEGINI XMATRI
  791.       CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
  792. C
  793. C  REMPLISSAGE DE XMATRI
  794. C
  795. *      SEGINI XMATRI
  796. *      IMATTT(IB)=XMATRI
  797. *      CALL REMPMC(REL,LRE,RE)
  798. *      SEGDES XMATRI
  799.  3056 CONTINUE
  800.       SEGDES xMATRI
  801.       SEGSUP WRK1,WRK3
  802.       GO TO 510
  803. C_______________________________________________________________________
  804. C
  805. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  806. C_______________________________________________________________________
  807. C
  808.   510 CONTINUE
  809.       SEGDES MELEME
  810.       SEGDES IMODEL
  811.       IF (IVAPR.NE.0) SEGDES MELVAL
  812. C
  813.       if(mele.ne.260)SEGDES MINTE
  814. C      SEGSUP INFO
  815. C_______________________________________________________________________
  816. C
  817. C      FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
  818. C_______________________________________________________________________
  819. C
  820.   500 CONTINUE
  821. C
  822.       SEGDES MRIGID
  823.       SEGDES MMODEL
  824.       SEGDES MCHEL1
  825.       SEGSUP,LIMODL
  826.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  827.       RETURN
  828. C
  829. C_______________________________________________________________________
  830. C
  831. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  832. C_______________________________________________________________________
  833. C
  834. C     ELEMENT NON IMPLEMENTE
  835. C
  836.    99 CONTINUE
  837.       MOTERR(1:4)=NOMTP(MELE)
  838.       MOTERR(5:12)='KPRES   '
  839.       CALL ERREUR(86)
  840. C
  841.  9990 CONTINUE
  842.       IRET=0
  843.  
  844.       IF(IVAPR.NE.0)SEGDES MELVAL
  845. C
  846.       SEGSUP,LIMODL
  847.       SEGDES MELEME
  848.       SEGDES IMODEL
  849.       SEGSUP DESCR
  850.       SEGSUP xMATRI
  851.  
  852.       SEGDES MMODEL
  853.       SEGDES MCHEL1
  854.       IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  855.       SEGDES MINTE
  856.       SEGSUP MRIGID
  857.  
  858.       RETURN
  859.       END
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  

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