Télécharger la plaquette Cast3M


fr en

Télécharger nlia.eso

Retour à la liste

Numérotation des lignes : 

nlia

  1. C NLIA      SOURCE    GOUNAND   26/01/09    21:15:42     12441          
  2.       SUBROUTINE NLIA(CGEOME,FACTIV,TABGEO,TABVDC,TATRAV,
  3.      $     METING,LAXI,LERF,LERJ,
  4.      $     MYFALS,MYPGS,MYFPGS,MYQRFS,
  5.      $     TABMAT,
  6.      $     IMPR,IRET)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8.       IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM         : NLIA
  11. C DESCRIPTION : Création d'une matrice intégration des termes de surface
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C               mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES          :
  18. C APPELE PAR       : PRLIN2
  19. C***********************************************************************
  20. C ENTREES            :
  21. C ENTREES/SORTIES    : -
  22. C SORTIES            :
  23. C TRAVAIL            : * SOUGEO (type MELEME) : maillage élémentaire.
  24. C                      * MLLRFS (type MLLRFS) : pointeurs sur les
  25. C                        éléments de référence associés aux 4 espaces de
  26. C                        discrétisation (géométrie, coefficient, primal,
  27. C                        dual) sur le maillage élémentaire.
  28. C                      * PGCOUR (type POGAU)  : méthode d'intégration
  29. C                        courante.
  30. C                      * JCOOR  (type MCHEVA) : valeurs du champ ICOOR
  31. C                        sur le maillage élémentaire.
  32. C                        Structure (cf.include SMCHAEL) :
  33. C                        (1, nb. ddl, 1, dim. esp. réel,
  34. C                         1, nb. éléments)
  35. C                      * JCOEFF (type MCHEVA) : valeurs du champ ICOEFF
  36. C                        sur le maillage élémentaire.
  37. C                        Structure (cf.include SMCHAEL) :
  38. C                        (1, nb. ddl, nb. comp. duales,
  39. C                         nb. comp. primales, 1, nb. éléments)
  40. C                      * JMTLIA (type MCHEVA) : valeurs du champ IMTLIA
  41. C                        sur le maillage élémentaire.
  42. C                        Structure (cf.include SMCHAEL) :
  43. C                        (nb. ddl dual, nb. ddl primal,
  44. C                         nb. comp. duales, nb. comp. primales,
  45. C                         1, nb. éléments)
  46. C                        nb. ddl primal=1 si la matrice est condensée.
  47. C                      * JMAJAC (type MCHEVA) : valeurs de la matrice
  48. C                        jacobienne aux points de Gauss sur le maillage
  49. C                        élémentaire.
  50. C                        Structure (cf.include SMCHAEL) :
  51. C                        (1, 1, dim. esp. réel, dim. esp. référence,
  52. C                         nb. poi. gauss, nb. éléments)
  53. C                      * JMIJAC (type MCHEVA) : valeurs de l'inverse de
  54. C                        la matrice jacobienne aux points de Gauss sur
  55. C                        le maillage élémentaire.
  56. C                        Structure (cf.include SMCHAEL) :
  57. C                        (1, 1, dim. esp. référence, dim. esp. réel,
  58. C                         nb. poi. gauss, nb. éléments)
  59. C                        JMIJAC n'existe que si dim.esp.réf=dim.esp.réel
  60. C                      * JDTJAC (type MCHEVA) : valeurs du déterminant
  61. C                        de la matrice jacobienne aux points de Gauss
  62. C                        sur le maillage élémentaire.
  63. C                        Structure (cf.include SMCHAEL) :
  64. C                        (1, 1, 1, 1, nb. poi. gauss, nb. éléments)
  65. C                        Si la matrice jacobienne n'est pas carrée, on
  66. C                        a calculé sqrt(det(trans(J).J))
  67. C                      * JCOEFG (type MCHEVA) : valeurs du coefficient
  68. C                        tensoriel aux points de Gauss sur le maillage
  69. C                        élémentaire.
  70. C                        Structure (cf.include SMCHAEL) :
  71. C                        (1, 1, nb. comp. duales, nb. comp. primales,
  72. C                         nb. poi. gauss, nb. éléments)
  73. C                      * FFPG (type MCHEVA) : valeurs des fonctions
  74. C                        d'interpolation aux points de gauss sur
  75. C                        l'élément de référence.
  76. C                        Structure (cf.include SMCHAEL) :
  77. C                        (1, nb. ddl, 1, 1, nb. poi. gauss, 1)
  78. C                      * DFFPG (type MCHEVA) : valeurs des dérivées
  79. C                        premières des fonctions d'interpolation aux
  80. C                        points de gauss sur l'élément de référence.
  81. C                        Structure (cf.include SMCHAEL) :
  82. C                        (1, nb. ddl, 1, dim.esp.réf, nb. poi. gauss, 1)
  83. C                      * JDFFPG (type MCHEVA) : valeurs des dérivées
  84. C                        premières des fonctions d'interpolation
  85. C                        primales aux points de gauss sur l'élément
  86. C                        réel.
  87. C                        Structure (cf.include SMCHAEL) :
  88. C                        (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss,
  89. C                         nb. élém.)
  90. C                      * JDFFDG (type MCHEVA) : valeurs des dérivées
  91. C                        premières des fonctions d'interpolation
  92. C                        duales aux points de gauss sur l'élément réel.
  93. C                        Structure (cf.include SMCHAEL) :
  94. C                        (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss,
  95. C                         nb. élém.)
  96. C***********************************************************************
  97. C VERSION    : v4, 26/07/06, refonte sur le modele du nlin evolue
  98. C VERSION    : v3, 11/05/04, refonte (ajout comportement)
  99. C VERSION    : v2, 22/09/03, refonte complète (modif SMTNLIN)
  100. C VERSION    : v1, 22/08/2003, version initiale
  101. C HISTORIQUE : v1, 22/08/2003, création
  102. C HISTORIQUE :
  103. C HISTORIQUE :
  104. C HISTORIQUE :
  105. C***********************************************************************
  106. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  107. C en cas de modification de ce sous-programme afin de faciliter
  108. C la maintenance !
  109. C***********************************************************************
  110. -INC PPARAM
  111. -INC CCOPTIO
  112. -INC CCGEOME
  113. -INC TNLIN
  114. *-INC SELREF
  115.       POINTEUR LRFVOL.ELREF
  116. *-INC SFALRF
  117.       POINTEUR MYFALS.FALRFS
  118. *-INC SPOGAU
  119.       POINTEUR MYPGS.POGAUS
  120. *-INC SFAPG
  121.       POINTEUR MYFPGS.FAPGS
  122. *-INC SLCOMP
  123.       POINTEUR MYCOM.COMP
  124.       POINTEUR IVCOMP.COMP
  125.       POINTEUR IVCOMD.COMP
  126. -INC SMLENTI
  127.       POINTEUR IPOWCO.MLENTI
  128. -INC SMELEME
  129.       POINTEUR CGEOME.MELEME
  130.       POINTEUR SOUGEO.MELEME
  131.       POINTEUR FACVOL.MELEME
  132.       POINTEUR SFAVOL.MELEME
  133. *
  134. *-INC SMCHAEL
  135.       INTEGER N1
  136.       POINTEUR ICOOR.MCHAEL
  137.       POINTEUR MYMCHA.MCHAEL
  138.       POINTEUR JXCOPG.MCHEVA
  139.       POINTEUR JXPOPG.MCHEVA
  140.       POINTEUR JCOOR.MCHEVA,JCOEFF.MCHEVA,JCOEFG.MCHEVA
  141.       POINTEUR JDCOFG.MCHEVA
  142.       POINTEUR JMAJAC.MCHEVA,JMIJAC.MCHEVA,JDTJAC.MCHEVA
  143.       POINTEUR JMAJA2.MCHEVA,JMIJA2.MCHEVA,JDTJA2.MCHEVA
  144.       POINTEUR JDTJA3.MCHEVA
  145.       POINTEUR IPROCO.MCHEVA
  146.       POINTEUR FC.MCHEVA
  147.       POINTEUR FFPG.MCHEVA,DFFPG.MCHEVA,JDFFPG.MCHEVA
  148.       POINTEUR FVPR.MCHEVA,FVDU.MCHEVA
  149.       POINTEUR FCPR.MCHEVA,FCDU.MCHEVA
  150.       POINTEUR JMTLIA.MCHEVA
  151. *-INC SMTNLIN
  152.       INTEGER NUMVPR,NUMVDU,NUMDER,NUMOP
  153.       INTEGER JGVC,KGVC
  154. *-INC SFACTIV
  155. *-INC SIQUAF
  156.       POINTEUR MYQRFS.IQUAFS
  157.       POINTEUR IQUVOL.IQUAF
  158.       POINTEUR IQUFAC.IQUAF
  159. *
  160.       CHARACTER*4 METING
  161.       INTEGER LAXI
  162.       INTEGER LERF
  163.       LOGICAL LERJ,LERJ2
  164.       INTEGER IMPR,IRET
  165. *
  166.       CHARACTER*4 MYDISC
  167. *
  168.       INTEGER NBELEF,NBELFV,NBELEV,NBSOFV,NBSOUV
  169.       INTEGER IBELEF,IBELFV,IBELEV,IBSOFV,IBSOUV
  170.       INTEGER IJVC,IKVC
  171.       INTEGER IVARPR,IVARDU,KDERPR,KDERDU,IOP
  172.       INTEGER ITYVOL,NBELEM
  173.       LOGICAL LF,LDF,LC,LDC
  174.       LOGICAL MVVPR,MVVDU,LVID
  175. *
  176. * Executable statements
  177. *
  178. *      IMPR=0
  179.       lerj2=.false.
  180.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nlia'
  181. * Activation et intialisation des chapeaux
  182.       SEGACT CGEOME
  183.       SEGACT FACTIV
  184.       SEGACT TABGEO
  185.       SEGACT TABVDC
  186.       SEGACT TATRAV*MOD
  187.       NBSOUV=CGEOME.LISOUS(/1)
  188.       NUMVPR=TABVDC.VVARPR(/1)
  189.       NUMVDU=TABVDC.VVARDU(/1)
  190.       JLCOF=TABVDC.VLCOF(/1)
  191.       JGCOF=TABVDC.VCOMP(/1)
  192.       JGVD=TABVDC.DJSVD(/1)
  193.       KGVD=TABVDC.DISVD(/2)
  194.       NUMDER=TABVDC.ILCPR(/1)-1
  195.       NUMOP=TABVDC.ILCPR(/2)
  196. *
  197.       N1=NBSOUV
  198. * NUMVPR et NUMVDU initialisés ci-dessus
  199.       SEGINI TABMAT
  200. * Cette instruction n'a pas l'air de fonctionner
  201. *      SEGINI TABMAT.VMAT(*)
  202.       DO IVARPR=1,NUMVPR
  203.          DO IVARDU=1,NUMVDU
  204.             SEGINI,MYMCHA
  205.             TABMAT.VMAT(IVARDU,IVARPR)=MYMCHA
  206.          ENDDO
  207.       ENDDO
  208.       SEGACT MYPGS
  209.       ICOOR=TABGEO.JGEO
  210.       SEGACT ICOOR
  211. *      SEGACT TABVC.NOMVC(*)
  212.       DO IJVD=1,JGVD
  213.          MYMCHA=TATRAV.IVD(IJVD)
  214.          IF (MYMCHA.NE.0) THEN
  215.             SEGACT MYMCHA
  216.          ENDIF
  217.       ENDDO
  218. *
  219. * On travaille sur chaque sous-domaine
  220. *
  221.       DO 1 IBSOUV=1,NBSOUV
  222.          SOUGEO=CGEOME.LISOUS(IBSOUV)
  223.          SEGACT SOUGEO
  224.          SFACTI=FACTIV.IFACTI(IBSOUV)
  225.          SEGACT,SFACTI
  226. *
  227.          NBELEV=SOUGEO.NUM(/2)
  228.          ITYVOL=SOUGEO.ITYPEL
  229. * Détermination de la dimension de l'espace de référence
  230.          CALL DIMELE(NOMS(ITYVOL),IESREF,IMPR,IRET)
  231.          IF (IRET.NE.0) GOTO 9999
  232. *
  233.          CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  234.          IF (IRET.NE.0) GOTO 9999
  235. *
  236.          SEGACT IQUVOL
  237.          FACVOL=IQUVOL.LFACE
  238.          SEGDES IQUVOL
  239.          SEGACT FACVOL
  240.          NBSOFV=FACVOL.LISOUS(/1)
  241. *
  242. * On travaille sur chaque type de face pour chaque sous-domaine
  243. *
  244.          DO 12 IBSOFV=1,NBSOFV
  245.             SFAVOL=FACVOL.LISOUS(IBSOFV)
  246.             SEGACT SFAVOL
  247.             NBELFV=SFAVOL.NUM(/2)
  248.             ITYFAC=SFAVOL.ITYPEL
  249.             CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  250.             IF (IRET.NE.0) GOTO 9999
  251.             SSFACT=SFACTI.ISFACT(IBSOFV)
  252. *   On calcule le nb de face pour un type de face d'un sous-domaine
  253.             SEGACT SSFACT
  254.             IBELEF=0
  255.             DO IBELEV=1,NBELEV
  256.                DO IBELFV=1,NBELFV
  257.                   IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN
  258.                      IBELEF=IBELEF+1
  259.                   ENDIF
  260.                ENDDO
  261.             ENDDO
  262.             SEGDES SSFACT
  263.             NBELEF=IBELEF
  264. *
  265. * Celui-ci peut être nul : Cas des prismes où on ne calcule des intégrales
  266. * de surface que sur les triangles
  267. *
  268.             IF (NBELEF.EQ.0) GOTO 12
  269.  
  270. *    Création des segments contenant les poids et points de Gauss sur
  271. *    toutes les faces de l'élément de référence.
  272. * In CREPG : SEGINI JXCOPG
  273. * In CREPG : SEGINI JXPOPG
  274.             CALL CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS,
  275.      $           JXCOPG,JXPOPG,
  276.      $           IMPR,IRET)
  277.             IF (IRET.NE.0) GOTO 9999
  278. *
  279. * Géométrie
  280. *
  281.             MYDISC=TABGEO.DISGEO
  282.             CALL KEEF(ITYVOL,MYDISC,
  283.      $           MYFALS,
  284.      $           LRFVOL,
  285.      $           IMPR,IRET)
  286.             IF (IRET.NE.0) GOTO 9999
  287. * In KFNRFF : SEGINI FFPG
  288. * In KFNRFF : SEGINI DFFPG
  289.             CALL KFNRFF(LRFVOL,JXCOPG,
  290.      $           FFPG,DFFPG,
  291.      $           IMPR,IRET)
  292.             IF (IRET.NE.0) GOTO 9999
  293. *
  294. * Création des matrices jacobiennes et déterminants
  295. * pour la transformation : élément volumique de référence <->
  296. *                          élément volumique réel
  297. * Ici, on ne se servira que de l'inverse de la matrice
  298. * jacobienne.
  299. * In GEOLIF : SEGINI JMAJAC
  300. * In GEOLIF : SEGINI JMIJAC
  301. * In GEOLIF : SEGINI JDTJAC
  302.             JCOOR=ICOOR.ICHEVA(IBSOUV)
  303.             CALL GEOLIF(DFFPG,JCOOR,SSFACT,NBELEF,
  304.      $           JMAJAC,JMIJAC,JDTJAC,
  305.      $           IMPR,IRET)
  306.             IF (IRET.NE.0) GOTO 9999
  307.             IF (JMIJAC.EQ.0.AND.LERJ) GOTO 9666
  308.             SEGSUP DFFPG
  309. *!            SEG SUP JMA JAC
  310. *!            SEG SUP JDT JAC
  311. *
  312. * Création des matrices jacobiennes et déterminants
  313. * pour la transformation : élément surfacique de référence <->
  314. *                          élément surfacique réel
  315. * Ici, on ne se servira que du déterminant de la matrice jacobienne.
  316. * In GEOLF2 : SEGINI JMAJA2
  317. * In GEOLF2 : SEGINI JMIJA2
  318. * In GEOLF2 : SEGINI JDTJA2
  319.             MYDISC=TABGEO.DISGEO
  320.             CALL GEOLF2(LRFVOL,IQUVOL,SFAVOL,
  321.      $           MYDISC,METING,MYFALS,MYFPGS,
  322.      $           JCOOR,SSFACT,NBELEF,
  323.      $           JMAJA2,JMIJA2,JDTJA2,
  324.      $           IMPR,IRET)
  325.             IF (IRET.NE.0) GOTO 9999
  326.             IF (JMIJAC.EQ.0.AND.LERJ2) THEN
  327.                LERJ=LERJ2
  328.                GOTO 9666
  329.             ENDIF
  330.             SEGSUP JMAJA2
  331.             IF (JMIJA2.NE.0) THEN
  332.                SEGSUP JMIJA2
  333.             ENDIF
  334.             SEGSUP FFPG
  335. C Inutile normalement, on peut se débrouiller avec les coeffs
  336. C* En axi, on multiplie le determinant de la matrice
  337. C* jacobienne par 2piR (ou R est la premiere coordonnee)
  338. C            IF (LAXI.GT.0) THEN
  339. C* In GEOMFT : SEGINI JDTJA3
  340. C               CALL GEOMFT(JCOOR,FFPG,SSFACT,NBELEF,
  341. C     $              JDTJA2,LAXI,
  342. C     $              JDTJA3,
  343. C     $              IMPR,IRET)
  344. C               IF (IRET.NE.0) GOTO 9999
  345. C               SEGSUP JDTJA2
  346. C               JDTJA2=JDTJA3
  347. C            ENDIF
  348. *
  349. * Attention : modif par rapport à nlin !
  350. *
  351.             JPC=0
  352.             JMAREG=0
  353.             JDIAMA=0
  354.             METRIQ=0
  355. *
  356. * Calcul des fonctions de forme et de leurs dérivées
  357. *
  358.             DO IKVD=1,KGVD
  359.                LF=TATRAV.LFFVD(IKVD).EQV..TRUE.
  360.                LDF=TATRAV.LDFFVD(IKVD).EQV..TRUE.
  361.                IF (LF.OR.LDF) THEN
  362.                   MYDISC=TABVDC.DISVD(IKVD)
  363.                   CALL KEEF(ITYVOL,MYDISC,
  364.      $                 MYFALS,
  365.      $                 LRFVOL,
  366.      $                 IMPR,IRET)
  367.                   IF (IRET.NE.0) GOTO 9999
  368. * In KFNRFF : SEGINI FFPG
  369. * In KFNRFF : SEGINI DFFPG
  370.                   CALL KFNRFF(LRFVOL,JXCOPG,
  371.      $                 FFPG,DFFPG,
  372.      $                 IMPR,IRET)
  373.                   IF (IRET.NE.0) GOTO 9999
  374.                   IF (LF) THEN
  375.                      TATRAV.FFVD(IKVD)=FFPG
  376.                   ELSE
  377. *                     segini ffpg
  378.                      SEGSUP FFPG
  379.                   ENDIF
  380.                   IF (LDF) THEN
  381.                      IF (LERF.NE.0) THEN
  382.                         SEGINI,JDFFPG=DFFPG
  383.                         SEGDES JDFFPG
  384.                      ELSE
  385. * In DFNFRF : SEGINI JDFFPG
  386.                         CALL DFNFRF(DFFPG,JMIJAC,SSFACT,NBELEF,
  387.      $                       JDFFPG,
  388.      $                       IMPR,IRET)
  389.                         IF (IRET.NE.0) GOTO 9999
  390.                      ENDIF
  391.                      TATRAV.DFFVD(IKVD)=JDFFPG
  392.                      ENDIF
  393.                      SEGSUP DFFPG
  394.                ENDIF
  395.             ENDDO
  396. *
  397. * Calcul des champs et de leurs dérivées
  398. *
  399.             DO IJVD=1,JGVD
  400.                LC=TATRAV.LVD(IJVD).EQV..TRUE.
  401.                LDC=TATRAV.LDVD(IJVD).EQV..TRUE.
  402.                IF (LC.OR.LDC) THEN
  403.                   MYMCHA=TATRAV.IVD(IJVD)
  404.                   JCOEFF=MYMCHA.ICHEVA(IBSOUV)
  405.                   IF (LC) THEN
  406.                      FFPG=TATRAV.FFVD(TABVDC.DJSVD(IJVD))
  407. * In COGAUF : SEGINI JCOEFG
  408.                      CALL COGAUF(JCOEFF,FFPG,SSFACT,NBELEF,
  409.      $                    JCOEFG,
  410.      $                    IMPR,IRET)
  411.                      IF (IRET.NE.0) GOTO 9999
  412.                      TATRAV.VD(IJVD)=JCOEFG
  413.                   ENDIF
  414.                   IF (LDC) THEN
  415.                      JDFFPG=TATRAV.DFFVD(TABVDC.DJSVD(IJVD))
  416. * In DCOGAF : SEGINI JDCOFG
  417.                      CALL DCOGAF(JCOEFF,JDFFPG,SSFACT,NBELEF,
  418.      $                    JDCOFG,
  419.      $                    IMPR,IRET)
  420.                      IF (IRET.NE.0) GOTO 9999
  421.                      TATRAV.DVD(IJVD)=JDCOFG
  422.                   ENDIF
  423.                ENDIF
  424.             ENDDO
  425. *!!!            SEG DES JMIJAC
  426. *
  427. * Calcul des coefficients
  428. *
  429.             DO IJGCOF=1,JGCOF
  430.                LC=TATRAV.LVCOF(IJGCOF).EQV..TRUE.
  431.                IF (LC) THEN
  432.                   IVCOMP=TABVDC.VCOMP(IJGCOF)
  433.                   IICOMP=TABVDC.VLDAT(IJGCOF)
  434. * In CALCGA : SEGINI FC
  435. * In CALCGA : SEG INI METRIQ.MCHEVA
  436.                   CALL CALCGA(IVCOMP,IICOMP,JMAJAC,JMIJAC,JDTJAC,
  437.      $                 JMAREG,JDIAMA,JPC,METRIQ,
  438.      $                 TATRAV,
  439.      $                 FC,IMPR,IRET)
  440.                   IF (IRET.NE.0) GOTO 9999
  441.                   TATRAV.VCOF(IJGCOF)=FC
  442.                ENDIF
  443.             ENDDO
  444. *
  445. * Calcul des produits de coefficients
  446. *
  447.             DO IJLCOF=1,JLCOF
  448.                IPOWCO=TABVDC.VLCOF(IJLCOF)
  449. * In CALPCO : SEGINI IPROCO
  450.                CALL CALPCO(IPOWCO,TATRAV,
  451.      $              IPROCO,IMPR,IRET)
  452.                IF (IRET.NE.0) GOTO 9999
  453.                TATRAV.VVCOF(IJLCOF)=IPROCO
  454.             ENDDO
  455. *
  456. * On peut faire le ménage dans les coefficients
  457. *
  458.             DO IJGCOF=1,JGCOF
  459.                FC=TATRAV.VCOF(IJGCOF)
  460.                IF (FC.NE.0) THEN
  461.                   SEGSUP,FC
  462.                   TATRAV.VCOF(IJGCOF)=0
  463.                ENDIF
  464.             ENDDO
  465. *
  466. * On effectue le calcul de la matrice
  467. *
  468.             DO IVARPR=1,NUMVPR
  469.                DO IVARDU=1,NUMVDU
  470. *Bug mis en evidence par toimp_3d                  JMTLIA=0
  471.                   MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  472.                   JMTLIA=MYMCHA.ICHEVA(IBSOUV)
  473.                   IJVARP=TABVDC.VVARPR(IVARPR)
  474.                   IJVARD=TABVDC.VVARDU(IVARDU)
  475.                   IKVARP=TABVDC.DJSVD(IJVARP)
  476.                   IKVARD=TABVDC.DJSVD(IJVARD)
  477.                   MVVPR=(TABVDC.MVD(IJVARP).NE.0)
  478.                   MVVDU=(TABVDC.MVD(IJVARD).NE.0)
  479.                   DO IOP=1,NUMOP
  480.                      DO KDERPR=0,NUMDER
  481.                         IJLCPR=TABVDC.ILCPR(KDERPR+1,IOP,IVARPR)
  482.                         IF (IJLCPR.NE.0) THEN
  483.                            FCPR=TATRAV.VVCOF(IJLCPR)
  484. * variable primale
  485.                            IF (KDERPR.EQ.0) THEN
  486.                               IF (MVVPR) THEN
  487.                                  FVPR=TATRAV.VD(IJVARP)
  488.                               ELSE
  489.                                  FVPR=TATRAV.FFVD(IKVARP)
  490.                               ENDIF
  491.                            ELSE
  492.                               IF (MVVPR) THEN
  493.                                  FVPR=TATRAV.DVD(IJVARP)
  494.                               ELSE
  495.                                  FVPR=TATRAV.DFFVD(IKVARP)
  496.                               ENDIF
  497.                            ENDIF
  498.                            DO KDERDU=0,NUMDER
  499.                               IJLCDU=TABVDC.ILCDU(KDERDU+1,IOP,IVARDU)
  500.                               IF (IJLCDU.NE.0) THEN
  501.                                  FCDU=TATRAV.VVCOF(IJLCDU)
  502. * Variable duale
  503.                                  IF (KDERDU.EQ.0) THEN
  504.                                     IF (MVVDU) THEN
  505.                                        FVDU=TATRAV.VD(IJVARD)
  506.                                     ELSE
  507.                                        FVDU=TATRAV.FFVD(IKVARD)
  508.                                     ENDIF
  509.                                  ELSE
  510.                                     IF (MVVDU) THEN
  511.                                        FVDU=TATRAV.DVD(IJVARD)
  512.                                     ELSE
  513.                                        FVDU=TATRAV.DFFVD(IKVARD)
  514.                                     ENDIF
  515.                                  ENDIF
  516. *                              WRITE(IOIMP,*) 'FVPR=',FVPR
  517. *                              WRITE(IOIMP,*) 'FVDU=',FVDU
  518. *                              WRITE(IOIMP,*) 'FCPR=',FCPR
  519. *                              WRITE(IOIMP,*) 'FCDU=',FCDU
  520. *                              WRITE(IOIMP,*) 'KDERPR=',KDERPR
  521. *                              WRITE(IOIMP,*) 'KDERDU=',KDERDU
  522. *                              WRITE(IOIMP,*) 'LDERPR=',LDERPR
  523. *                              WRITE(IOIMP,*) 'LDERDU=',LDERDU
  524. *                                 SEGPRT,JXPOPG
  525. *                                 SEGPRT,FVPR
  526. *                                 SEGPRT,FVDU
  527. *                                 SEGPRT,FCPR
  528. *                                 SEGPRT,FCDU
  529. *                                 SEGPRT,JDTJA2
  530. *                                 WRITE(IOIMP,*) 'KDERPR=',KDERPR
  531. *                                 WRITE(IOIMP,*) 'KDERDU=',KDERDU
  532. C                                 WRITE(IOIMP,*) 'LDERPR=',LDERPR
  533. C                                 WRITE(IOIMP,*) 'LDERDU=',LDERDU
  534. C                                 SEGPRT,JDTJA2
  535. C                                 WRITE(IOIMP,*) 'NBELEF=',NBELEF
  536.                                  CALL LIALIN(JXPOPG,
  537.      $                                FVPR,FVDU,FCPR,FCDU,
  538.      $                                KDERPR,KDERDU,
  539.      $                                JDTJA2,SSFACT,NBELEF,LERF,IESREF,
  540.      $                                JMTLIA,
  541.      $                                IMPR,IRET)
  542.                                  IF (IRET.NE.0) GOTO 9999
  543. C                                 WRITE(IOIMP,*) 'JMTLIA=',JMTLIA
  544. C                                 SEGPRT,JMTLIA
  545. C*                                 STOP 16
  546.                               ENDIF
  547.                            ENDDO
  548.                         ENDIF
  549.                      ENDDO
  550.                   ENDDO
  551.                   MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  552.                   MYMCHA.JMACHE(IBSOUV)=SOUGEO
  553.                   MYMCHA.ICHEVA(IBSOUV)=JMTLIA
  554. *               IF (JMTLIA.NE.0) THEN
  555. *                  SEGPRT,JMTLIA
  556. *               ENDIF
  557. C               WRITE(IOIMP,*) 'IVARPR=',IVARPR
  558. C               WRITE(IOIMP,*) 'IVARDU=',IVARDU
  559. C               WRITE(IOIMP,*) 'JMTLIA=',JMTLIA
  560.                ENDDO
  561.             ENDDO
  562. * Suppression de tous les MCHEVA
  563.             DO IJLCOF=1,JLCOF
  564.                IPROCO=TATRAV.VVCOF(IJLCOF)
  565.                SEGSUP IPROCO
  566.                TATRAV.VVCOF(IJLCOF)=IPROCO
  567.             ENDDO
  568. *
  569.             DO IJVD=1,JGVD
  570.                JCOEFG=TATRAV.VD(IJVD)
  571.                IF (JCOEFG.NE.0) THEN
  572.                   SEGSUP JCOEFG
  573.                   TATRAV.VD(IJVD)=JCOEFG
  574.                ENDIF
  575.                JDCOFG=TATRAV.DVD(IJVD)
  576.                IF (JDCOFG.NE.0) THEN
  577.                   SEGSUP JDCOFG
  578.                   TATRAV.DVD(IJVD)=JDCOFG
  579.                ENDIF
  580.             ENDDO
  581. *
  582.             DO IKVD=1,KGVD
  583.                FFPG=TATRAV.FFVD(IKVD)
  584.                IF (FFPG.NE.0) THEN
  585.                   SEGSUP FFPG
  586.                   TATRAV.FFVD(IKVD)=FFPG
  587.                ENDIF
  588.                JDFFPG=TATRAV.DFFVD(IKVD)
  589.                IF (JDFFPG.NE.0) THEN
  590.                   SEGSUP JDFFPG
  591.                   TATRAV.DFFVD(IKVD)=JDFFPG
  592.                ENDIF
  593.             ENDDO
  594. *
  595.             SEGSUP JDTJA2
  596.             SEGSUP JXPOPG
  597.             SEGSUP JXCOPG
  598.             SEGDES SFAVOL
  599.             SEGSUP JDTJAC
  600.             SEGSUP JMAJAC
  601.             SEGSUP JMIJAC
  602.  12      CONTINUE
  603. *         SEGPRT,JMTLIA
  604.          SEGDES FACVOL
  605.          SEGDES SFACTI
  606.          SEGDES SOUGEO
  607.  1    CONTINUE
  608. *
  609.       DO IJVD=1,JGVD
  610.          MYMCHA=TATRAV.IVD(IJVD)
  611.          IF (MYMCHA.NE.0) THEN
  612.             SEGDES MYMCHA
  613.          ENDIF
  614.       ENDDO
  615. *      SEGDES TABVC.NOMVC(*)
  616.       SEGDES ICOOR
  617.       SEGDES MYPGS
  618. * Cette instruction n'a pas l'air de fonctionner
  619. * Un peu de ménage là où il n'y a pas d'info
  620. *      SEGDES TABMAT.VMAT(*)
  621.       DO IVARPR=1,NUMVPR
  622.          DO IVARDU=1,NUMVDU
  623.             MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  624.             SEGACT MYMCHA
  625.             LVID=.TRUE.
  626.             DO ISOUS=1,NBSOUV
  627.                MCHEVA=MYMCHA.ICHEVA(ISOUS)
  628.                LVID=LVID.AND.(MCHEVA.EQ.0)
  629.             ENDDO
  630.             IF (LVID) THEN
  631.                SEGSUP MYMCHA
  632.                TABMAT.VMAT(IVARDU,IVARPR)=0
  633.             ELSE
  634.                SEGDES,MYMCHA
  635.             ENDIF
  636.          ENDDO
  637.       ENDDO
  638.       SEGDES TATRAV
  639.       SEGDES TABMAT
  640.       SEGDES TABVDC
  641.       SEGDES TABGEO
  642.       SEGDES FACTIV
  643.       SEGDES CGEOME
  644. *
  645. * Normal termination
  646. *
  647.       IRET=0
  648.       RETURN
  649. *
  650. * Format handling
  651. *
  652. *
  653. * Error handling
  654. *
  655.  9666 CONTINUE
  656.       IRET=666
  657.       RETURN
  658.  9999 CONTINUE
  659.       IRET=1
  660.       WRITE(IOIMP,*) 'An error was detected in subroutine nlia'
  661.       RETURN
  662. *
  663. * End of subroutine nlia
  664. *
  665.       END
  666.  
  667.  

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