Télécharger la plaquette Cast3M


fr en

Télécharger kbloq.eso

Retour à la liste

Numérotation des lignes : 

kbloq

  1. C KBLOQ     SOURCE    GOUNAND   25/04/30    21:15:09     12258          
  2.       SUBROUTINE KBLOQ(CBLOQ,MBLOQ,FBLOQ)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : KBLOQ
  7. C DESCRIPTION : a partir d'un CHPOINT de CLIM de Dirichlet,
  8. *     genere la rigidite de blocage et la force associee au blocage
  9. *
  10. C
  11. C
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  15. C               mel : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C***********************************************************************
  18. C SYNTAXE GIBIANE    :
  19. C ENTREES            : CBLOQ
  20. C ENTREES/SORTIES    :
  21. C SORTIES            : MBLOQ, FBLOQ
  22. C***********************************************************************
  23. C VERSION    : v1, 29/04/2025, version initiale
  24. C HISTORIQUE : v1, 29/04/2025, creation
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMCOORD
  31. -INC CCGEOME
  32. -INC CCHAMP
  33. -INC SMELEME
  34.       POINTEUR melrig.MELEME
  35. -INC SMCHPOI
  36.       POINTEUR CBLOQ.MCHPOI
  37.       POINTEUR FBLOQ.MCHPOI
  38. -INC SMRIGID
  39.       POINTEUR MBLOQ.MRIGID
  40. -INC SMLMOTS
  41.       POINTEUR MLCOMP.MLMOTS
  42. -INC SMLENTI
  43.       POINTEUR NCNODE.MLENTI
  44.       POINTEUR ICNODE.MLENTI
  45.       CHARACTER*(LOCHPO) nompri,nomdua
  46.       CHARACTER*4 MOTPV(3)
  47.       DATA MOTPV / 'MINI','MAXI','FROT' /
  48. *
  49. * Executable statements
  50. *
  51. C  Est-ce une condition unilaterale ?
  52.       NILATE=0
  53.       CALL LIRMOT(MOTPV,3,IPO,0)
  54.       IF (IPO.EQ.1) NILATE=-1
  55.       IF (IPO.EQ.2) NILATE=1
  56.       IF (IPO.EQ.3) NILATE=2
  57. C  Pas de frottement en 1D
  58.       IF (IPO.EQ.3.AND.IDIM.EQ.1) THEN
  59.          INTERR(1)=IDIM
  60.          MOTERR(1:4)=MOTPV(3)
  61.          CALL ERREUR(971)
  62.          RETURN
  63.       ENDIF
  64. C  Pour ne pas avoir de verrouillage sur MCOORD en //
  65.       SEGDES,MCOORD
  66.       SEGACT,MCOORD*MOD
  67. *     On parcourt le champ pour avoir les noms de composante et le
  68. *     nombre de noeuds concernes par composante
  69. *
  70.       CALL EXTR11(CBLOQ,MLCOMP)
  71.       NLCOMP=MLCOMP.MOTS(/2)
  72.       JG=NLCOMP
  73.       SEGINI NCNODE
  74.       SEGINI ICNODE
  75.       NSOUPO=CBLOQ.IPCHP(/1)
  76.       NLAG=0
  77.       DO ISOUPO=1,NSOUPO
  78.          MSOUP1=CBLOQ.IPCHP(ISOUPO)
  79.          NC=MSOUP1.NOCOMP(/2)
  80.          IPT1=MSOUP1.IGEOC
  81.          NGEOC=IPT1.NUM(/2)
  82.          DO IC=1,NC
  83.             nompri=msoup1.nocomp(ic)
  84.             CALL PLACE(MLCOMP.MOTS,NLCOMP,IPLAC,nompri)
  85.             IF (IPLAC.LE.0) THEN
  86.                CALL ERREUR(5)
  87.                GOTO 9999
  88.             ENDIF
  89.             NCNODE.LECT(IPLAC)=NCNODE.LECT(IPLAC)+NGEOC
  90.             NLAG=NLAG+NGEOC
  91.          ENDDO
  92.       ENDDO
  93.       ILAG=0
  94.       NULAG=NBPTS
  95.       NBPTS=NBPTS+NLAG
  96.       SEGADJ,MCOORD
  97. *
  98. *     On va creer un nombre de sous-matrices egale aux nombres de
  99. *     composantes
  100. *
  101.       NRIGEL=NLCOMP
  102.       SEGINI MRIGID
  103.       MTYMAT='KOPSBLOQ'
  104.       DO irig=1,nrigel
  105.          coerig(irig)=1.d0
  106.          nbnn=2
  107.          nbelem=ncnode.lect(irig)
  108.          nbsous=0
  109.          nbref=0
  110.          segini meleme
  111.          itypel=22
  112.          irigel(1,irig)=meleme
  113.          nligrp=2
  114.          nligrd=2
  115.          segini descr
  116.          nompri=MLCOMP.MOTS(irig)
  117.          CALL PLACE(NOMDD,LNOMDD,inomdd,nompri)
  118.          if (inomdd.le.0) then
  119.             moterr(1:4)=nompri
  120.             call erreur(108)
  121.             goto 9999
  122.          endif
  123.          nomdua=nomdu(inomdd)
  124.          lisinc(1)='LX'
  125.          lisdua(1)='FLX'
  126.          lisinc(2)=nompri
  127.          lisdua(2)=nomdua
  128.          NOELEP(1)=1
  129.          NOELEP(2)=2
  130.          NOELED(1)=1
  131.          NOELED(2)=2
  132.          irigel(3,irig)=descr
  133.          nelrig=ncnode.lect(irig)
  134.          segini xmatri
  135.          xmatri.symre=0
  136.          do ilrig=1,nelrig
  137.             re(1,1,ilrig)=0.D0
  138.             re(2,1,ilrig)=1.D0
  139.             re(1,2,ilrig)=1.D0
  140.             re(2,2,ilrig)=0.D0
  141.          enddo
  142.          irigel(4,irig)=xmatri
  143.          irigel(5,irig)=NIFOUR
  144.          irigel(6,irig)=NILATE
  145.          irigel(7,irig)=0
  146.       ENDDO
  147. *
  148. *     On va creer un chpoint a une composante FLX
  149. *
  150.       NSOUPO=1
  151.       NAT=1
  152.       SEGINI,MCHPOI
  153.       MTYPOI='FLX'
  154.       JATTRI(1) = 2
  155.       MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
  156.      #  ' KBLOQ'
  157.       IFOPOI=IFOUR
  158.       NC=1
  159.       SEGINI,MSOUPO
  160.       IPCHP(1)=MSOUPO
  161.       NOCOMP(1)='FLX'
  162.       NOHARM(1)=NIFOUR
  163.       NBNN=1
  164.       NBELEM=NLAG
  165.       SEGINI MELEME
  166.       IGEOC=MELEME
  167.       ITYPEL=1
  168.       N=NLAG
  169.       SEGINI,MPOVAL
  170.       IPOVAL=MPOVAL
  171. *
  172. *   On parcourt CBLOQ pour remplir les sorties manquantes
  173. *
  174.       NSOUPO=CBLOQ.IPCHP(/1)
  175.       DO ISOUPO=1,NSOUPO
  176.          MSOUP1=CBLOQ.IPCHP(ISOUPO)
  177.          NC=MSOUP1.NOCOMP(/2)
  178.          IPT1=MSOUP1.IGEOC
  179.          MPOVA1=MSOUP1.IPOVAL
  180.          NGEOC=IPT1.NUM(/2)
  181.          DO IC=1,NC
  182.             nompri=msoup1.nocomp(ic)
  183.             CALL PLACE(MLCOMP.MOTS,NLCOMP,IPLAC,nompri)
  184.             IF (IPLAC.LE.0) THEN
  185.                CALL ERREUR(5)
  186.                GOTO 9999
  187.             ENDIF
  188.             melrig=irigel(1,iplac)
  189.             ideb=ICNODE.LECT(IPLAC)
  190.             DO I=1,NGEOC
  191.                ideb=ideb+1
  192.                ilag=ilag+1
  193.                nulag=nulag+1
  194.                melrig.num(1,ideb)=nulag
  195.                melrig.num(2,ideb)=ipt1.num(1,i)
  196.                num(1,ilag)=nulag
  197.                vpocha(ilag,1)=mpova1.vpocha(i,ic)
  198.             ENDDO
  199.             ICNODE.LECT(IPLAC)=ICNODE.LECT(IPLAC)+NGEOC
  200.          ENDDO
  201.       ENDDO
  202.       segsup icnode
  203.       segsup ncnode
  204.       MBLOQ=MRIGID
  205.       FBLOQ=MCHPOI
  206. *
  207. * Normal termination
  208. *
  209.       RETURN
  210. *
  211. * Format handling
  212. *
  213. *
  214. * Error handling
  215. *
  216.  9999 CONTINUE
  217.       WRITE(IOIMP,*) 'An error was detected in subroutine kbloq'
  218.       RETURN
  219. *
  220. * End of subroutine KBLOQ
  221. *
  222.       END
  223.  
  224.  

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