Télécharger la plaquette Cast3M


fr en

Télécharger nif.eso

Retour à la liste

Numérotation des lignes : 

nif

  1. C NIF       SOURCE    FANDEUR   22/05/02    21:15:27     11359          
  2.       SUBROUTINE NIF(LRFVOL,JXCOPG,PNM1,
  3.      $     FNPG,DFNPG,
  4.      $     IMPR,IRET)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.       IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM         : NIF
  9. C PROJET      : Noyau linéaire NLIN
  10. C DESCRIPTION : Calcul des valeurs des fonctions de forme et des
  11. C               valeurs de leurs dérivées premières aux points de Gauss.
  12. C
  13. C               On utilise la relation (produit) suivante :
  14. C
  15. C               < Ni (point) > = < Pi (point) > [Pn]^{-1}
  16. C
  17. C               avec (cf. CALPN) :
  18. C               [PN] = ( P1(ksi1)  .....   Pn(ksi1))
  19. C                      (   ...     .....     ...   )
  20. C                      ( P1(ksin)  .....   Pn(ksin))
  21. C               n = nb. ddl sur l'élément (NDFN)
  22. C               ksii = coords. du ieme noeud d'approximation
  23. C                      dans l'espace de référence (de dimension
  24. C                      NDIML)
  25. C               Pi   = ieme polynome d'interpolation sur
  26. C                      l'élément de référence.
  27. C               Ni   = ieme fonction nodale d'interpolation sur
  28. C                      l'élément de référence.
  29. C               point= point quelconque sur l'élément de référence
  30. C                      (donc en particulier les points de Gauss)
  31. C LANGAGE     : Esope
  32. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  33. C               mél : gounand@semt2.smts.cea.fr
  34. C***********************************************************************
  35. C APPELES          : VALPOL, NOMINC
  36. C APPELE PAR       : KFNREF
  37. C***********************************************************************
  38. C ENTREES            : LRFVOL, MYPG, PNM1
  39. C ENTREES/SORTIES    : -
  40. C SORTIES            : FNPG, DFNPG
  41. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  42. C***********************************************************************
  43. C VERSION    : v1, 16/09/99, version initiale
  44. C HISTORIQUE : v1, 16/09/99, création
  45. C HISTORIQUE : v2, 10/05/00, modif. du segment ELREF
  46. C HISTORIQUE :
  47. C HISTORIQUE :
  48. C***********************************************************************
  49. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  50. C en cas de modification de ce sous-programme afin de faciliter
  51. C la maintenance !
  52. C***********************************************************************
  53.  
  54. -INC PPARAM
  55. -INC CCOPTIO
  56. -INC TNLIN      
  57. *-INC SELREF
  58.       POINTEUR LRFVOL.ELREF
  59. *-INC SPOLYNO
  60.       POINTEUR MYBPOL.POLYNS
  61.       POINTEUR MYPOLY.POLYNO
  62. -INC TMXMAT
  63.       POINTEUR PNM1.MXMAT
  64. -INC SMLENTI
  65.       INTEGER JG
  66.       POINTEUR ORDER1.MLENTI
  67. -INC SMLREEL
  68.       POINTEUR VECTPI.MLREEL
  69. *-INC SMCHAEL
  70.       POINTEUR JXCOPG.MCHEVA
  71.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  72.       POINTEUR FNPG.MCHEVA
  73.       POINTEUR DFNPG.MCHEVA
  74. *
  75.       INTEGER IMPR,IRET
  76. *
  77. * Fonction Blas (produit scalaire)
  78. *
  79.       REAL*8   DDOT
  80.       EXTERNAL DDOT
  81. *
  82.       INTEGER NBMONO
  83.       INTEGER NDIMQR,       NPGFAC,NBFN,NBELFV
  84.       INTEGER IDIMQR,JDIMQR,IPGFAC,IBFN,IBELFV
  85. *
  86. * Executable statements
  87. *
  88.  
  89.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nif'
  90. *
  91. * Initialisations
  92. *
  93. *      SEGPRT,JXCOPG
  94. *      SEGPRT,LRFVOL
  95. *      SEGPRT,PNM1
  96.       SEGACT JXCOPG
  97.       NDIMQR=JXCOPG.WELCHE(/4)
  98.       NPGFAC=JXCOPG.WELCHE(/5)
  99.       NBELFV=JXCOPG.WELCHE(/6)
  100.       SEGACT LRFVOL
  101.       MYBPOL=LRFVOL.MBPOLY
  102.       SEGDES LRFVOL
  103.       SEGACT MYBPOL
  104.       SEGACT MYBPOL.LIPOLY(*)
  105.       NBFN=MYBPOL.LIPOLY(/1)
  106.       SEGACT PNM1
  107.       JG=NDIMQR
  108.       SEGINI ORDER1
  109.       JG=NBFN
  110.       SEGINI VECTPI
  111. *
  112. * On calcule les valeurs des fonctions de forme aux points de Gauss
  113. *
  114.       NBLIG=1
  115.       NBCOL=NBFN
  116.       N2LIG=1
  117.       N2COL=1
  118.       NBPOI=NPGFAC
  119.       NBELM=NBELFV
  120.       SEGINI FNPG
  121.       DO 1 IDIMQR=1,NDIMQR
  122.          ORDER1.LECT(IDIMQR)=0
  123.  1    CONTINUE
  124.       DO IBELFV=1,NBELFV
  125.          DO 3 IPGFAC=1,NPGFAC
  126. * Calcul de < P (pg) > = < P1(pg) ... Pnbfn(pg) > où pg est le
  127. * IPGFACieme point de Gauss
  128.             DO 32 IBFN=1,NBFN
  129.                MYPOLY=MYBPOL.LIPOLY(IBFN)
  130.                NBMONO=MYPOLY.EXPMON(/2)
  131.                CALL VALPOL(NDIMQR,NBMONO,
  132.      $              JXCOPG.WELCHE(1,1,1,1,IPGFAC,IBELFV),
  133.      $              MYPOLY.COEMON,MYPOLY.EXPMON,
  134.      $              ORDER1.LECT,
  135.      $              VECTPI.PROG(IBFN),
  136.      $              IMPR,IRET)
  137.                IF (IRET.NE.0) GOTO 9999
  138.  32         CONTINUE
  139. * On calcule : < N (pg) > = < P (pg) > [Pn]^{-1}
  140.             DO 34 IBFN=1,NBFN
  141.                FNPG.WELCHE(1,IBFN,1,1,IPGFAC,IBELFV)=
  142.      $              DDOT(NBFN,VECTPI.PROG,1,PNM1.XMAT(1,IBFN),1)
  143.  34         CONTINUE
  144.  3       CONTINUE
  145.          IF (IMPR.GT.3) THEN
  146.             WRITE(IOIMP,*) 'Face n° ',IBELFV
  147.             WRITE(IOIMP,*) 'Ordre de dérivation / coordonnée de réf. :'
  148.             WRITE(IOIMP,4003) (ORDER1.LECT(IDIMQR),IDIMQR=1,NDIMQR)
  149.             DO 5 IPGFAC=1,NPGFAC
  150.                WRITE(IOIMP,*) 'Noeud de coordonnées :'
  151.                WRITE(IOIMP,4004)
  152.      $              (JXCOPG.WELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV),IDIMQR=1
  153.      $              ,NDIMQR)
  154.                WRITE(IOIMP,*) 'FNPG.WELCHE(nb.fns.forme) :'
  155.                WRITE(IOIMP,4004)
  156.      $              (FNPG.WELCHE(1,IBFN,1,1,IPGFAC,IBELFV),IBFN=1,NBFN
  157.      $              )
  158.  5          CONTINUE
  159.          ENDIF
  160.       ENDDO
  161.       SEGDES FNPG
  162. *
  163. * On calcule les valeurs des dérivées premières des fonctions
  164. * de forme aux points de Gauss
  165. *
  166.       NBLIG=1
  167.       NBCOL=NBFN
  168.       N2LIG=1
  169.       N2COL=NDIMQR
  170.       NBPOI=NPGFAC
  171.       NBELM=NBELFV
  172.       SEGINI DFNPG
  173.       DO 7 IDIMQR=1,NDIMQR
  174.          DO 72 JDIMQR=1,NDIMQR
  175.             IF (JDIMQR.EQ.IDIMQR) THEN
  176.                ORDER1.LECT(JDIMQR)=1
  177.             ELSE
  178.                ORDER1.LECT(JDIMQR)=0
  179.             ENDIF
  180.  72      CONTINUE
  181.          DO IBELFV=1,NBELFV
  182.             DO 74 IPGFAC=1,NPGFAC
  183.                DO 742 IBFN=1,NBFN
  184. * Calcul de < dP/dksi_idimqr (pg) > où pg est le
  185. * IPGFACieme point de Gauss
  186.                   MYPOLY=MYBPOL.LIPOLY(IBFN)
  187.                   NBMONO=MYPOLY.EXPMON(/2)
  188.                   CALL VALPOL(NDIMQR,NBMONO,
  189.      $                 JXCOPG.WELCHE(1,1,1,1,IPGFAC,IBELFV),
  190.      $                 MYPOLY.COEMON,MYPOLY.EXPMON,
  191.      $                 ORDER1.LECT,
  192.      $                 VECTPI.PROG(IBFN),
  193.      $                 IMPR,IRET)
  194.                   IF (IRET.NE.0) GOTO 9999
  195.  742           CONTINUE
  196. * On calcule : < dN/dksi_idimqr (pg) > = < dP/dksi_idimqr (pg) > [Pn]^{-1}
  197.                DO 744 IBFN=1,NBFN
  198.                   DFNPG.WELCHE(1,IBFN,1,IDIMQR,IPGFAC,IBELFV)=
  199.      $                 DDOT(NBFN,VECTPI.PROG,1,PNM1.XMAT(1,IBFN),1)
  200.  744           CONTINUE
  201.  74         CONTINUE
  202.             IF (IMPR.GT.3) THEN
  203.                WRITE(IOIMP,*)
  204.      $              'Ordre de dérivation / coordonnée de réf. :'
  205.                WRITE(IOIMP,4003) (ORDER1.LECT(JDIMQR),JDIMQR=1,NDIMQR)
  206.                DO 76 IPGFAC=1,NPGFAC
  207.                   WRITE(IOIMP,*) 'Face n° ',IBELFV
  208.                   WRITE(IOIMP,*) 'Noeud de coordonnées :'
  209.                   WRITE(IOIMP,4004) (JXCOPG.WELCHE(1,1,1,JDIMQR,IPGFAC
  210.      $                 ,IBELFV),JDIMQR=1,NDIMQR)
  211.                   WRITE(IOIMP,*) 'DFNPG.WELCHE(nb.fns.forme) :'
  212.                   WRITE(IOIMP,4004)
  213.      $                 (DFNPG.WELCHE(1,IBFN,1,IDIMQR,IPGFAC,IBELFV),
  214.      $                 IBFN=1,NBFN)
  215.  76            CONTINUE
  216.             ENDIF
  217.          ENDDO
  218.  7    CONTINUE
  219.       SEGDES DFNPG
  220.       SEGSUP VECTPI
  221.       SEGSUP ORDER1
  222.       SEGDES PNM1
  223.       SEGDES MYBPOL.LIPOLY(*)
  224.       SEGDES MYBPOL
  225.       SEGDES JXCOPG
  226. *
  227. * Normal termination
  228. *
  229.       IRET=0
  230.       RETURN
  231. *
  232. * Format handling
  233. *
  234.  4003 FORMAT (2X,6(1X,I3))
  235.  4004 FORMAT (2X,6(1X,1PE13.5))
  236. *
  237. * Error handling
  238. *
  239.  9999 CONTINUE
  240.       IRET=1
  241.       WRITE(IOIMP,*) 'An error was detected in subroutine nif'
  242.       RETURN
  243. *
  244. * End of subroutine NIF
  245. *
  246.       END
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  

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