Télécharger la plaquette Cast3M


fr en

Télécharger promat.eso

Retour à la liste

Numérotation des lignes : 

promat

  1. C PROMAT    SOURCE    CB215821  20/11/25    13:37:23     10792          
  2.       SUBROUTINE PROMAT(MPRIB,MDUAB,IMATB,
  3.      $           MPRIC,MDUAC,IMATC,
  4.      $           CHPOD,
  5.      $           MPCDB,MDCDB,IMTCDB,
  6.      $     IMPR,IRET)
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8 (A-H,O-Z)
  9. C***********************************************************************
  10. C NOM         : PROMAT
  11. C DESCRIPTION : Produit de matrices élémentaires.
  12. C
  13. C
  14. C LANGAGE     : ESOPE
  15. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  16. C               mél : gounand@semt2.smts.cea.fr
  17. C***********************************************************************
  18. C APPELES          : REPICO, INCCOM, KRIPEE
  19. C                            MELCOM, KRIPME
  20. C                    RPENEN, EXINCS, RPENLE, MKNBNC, MIPCDB, MIDCDB
  21. C                    RPELEN, ML2LIE, RPELLE, MKLBLC,         MLDCDB
  22. C                    CP2LR,  MA2LIR, PROLIS, LI2MAS
  23. C APPELES (STAT.)  : PRMSTA, INMSTA
  24. C APPELE PAR       : PRCMCT
  25. C***********************************************************************
  26. C ENTREES            : MPRIB, MDUAB, IMATB, MPRIC, MDUAC, IMATC, CHPOD
  27. C SORTIES            : MPCDB, MDCDB, IMTCDB
  28. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  29. C***********************************************************************
  30. C VERSION    : v1, 12/05/99, version initiale
  31. C HISTORIQUE : v1, 12/05/99, création
  32. C HISTORIQUE :
  33. C HISTORIQUE :
  34. C***********************************************************************
  35. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  36. C en cas de modification de ce sous-programme afin de faciliter
  37. C la maintenance !
  38. C***********************************************************************
  39. *
  40. * Il faudra faire les suppressions de segments en tenant
  41. * compte des exceptions.
  42. *
  43.  
  44. -INC PPARAM
  45. -INC CCOPTIO
  46. -INC SMCOORD
  47. -INC SMELEME
  48.       POINTEUR MPRIB.MELEME
  49.       POINTEUR MDUAB.MELEME
  50.       POINTEUR MPRIC.MELEME
  51.       POINTEUR MDUAC.MELEME
  52.       POINTEUR MPCDB.MELEME
  53.       POINTEUR MDCDB.MELEME
  54.       POINTEUR MAIPRI.MELEME
  56.       POINTEUR IMATB.IMATRI
  57.       POINTEUR IMATC.IMATRI
  58.       POINTEUR IMTCDB.IMATRI
  59. -INC SMCHPOI
  60.       POINTEUR CHPOD.MCHPOI
  61. -INC SMLMOTS
  62.       POINTEUR ICOGLO.MLMOTS
  63. -INC SMLENTI
  64.       POINTEUR ICPRIB.MLENTI
  65.       POINTEUR ICDUAB.MLENTI
  66.       POINTEUR ICPRIC.MLENTI
  67.       POINTEUR ICDUAC.MLENTI
  68.       POINTEUR ICPRID.MLENTI
  69.       POINTEUR JCPRIB.MLENTI
  70.       POINTEUR JCDUAB.MLENTI
  71.       POINTEUR JCPRIC.MLENTI
  72.       POINTEUR JCDUAC.MLENTI
  73.       POINTEUR ICOPRI.MLENTI
  74.       POINTEUR KRIPRI.MLENTI
  75.       POINTEUR LNBMEB.MLENTI
  76.       POINTEUR LNBMEC.MLENTI
  77.       POINTEUR ICPCDB.MLENTI
  78.       POINTEUR KRMPRI.MLENTI
  79.       POINTEUR LELEMB.MLENTI
  80.       POINTEUR LELEMC.MLENTI
  81. *
  82. * Includes persos
  83. *
  84. *
  85. *     Segment LSTIND (liste séquentielle indexée)
  86. *
  87.       SEGMENT LSTIND
  88.       INTEGER IDX(NBM+1)
  89.       INTEGER IVAL(NBTVAL)
  90.       ENDSEGMENT
  91. *
  92. *     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  93. *
  94. *     NBM      : NOMBRE DE MULTIPLETS
  95. *     NBTVAL   : NOMBRE TOTAL DE VALEURS
  96. *     IDX(I)   : INDICE DE LA PREMIERE VALEUR DU IEME
  97. *                MULTIPLET DANS LE TABLEAU IVAL
  98. *     IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  99. *-INC SLSTIND
  100.       POINTEUR LIPNMC.LSTIND
  101.       POINTEUR LINBNC.LSTIND
  102.       POINTEUR ICDCDB.LSTIND
  103.       POINTEUR LMDUAB.LSTIND
  104.       POINTEUR LMPRIB.LSTIND
  105.       POINTEUR LMPRIC.LSTIND
  106.       POINTEUR LMDUAC.LSTIND
  107.       POINTEUR LIPNLC.LSTIND
  108.       POINTEUR LILBLC.LSTIND
  109.       POINTEUR LMPCDB.LSTIND
  110.       POINTEUR LMDCDB.LSTIND
  111.       SEGMENT LSRIND
  112.       INTEGER IDXX(NBM+1)
  113.       REAL*8 XVAL(NBTVAL)
  114.       ENDSEGMENT
  115.       SEGMENT LLI
  116.       POINTEUR LISLI(NBME).LSRIND
  117.       ENDSEGMENT
  118.       POINTEUR LMATRB.LLI
  119.       POINTEUR LMATRC.LLI
  120.       POINTEUR LMACDB.LLI
  121. -INC SMLREEL
  122.       SEGMENT LLR
  123.       POINTEUR LISLR(NBME).MLREEL
  124.       ENDSEGMENT
  125.       POINTEUR LCHPOD.LLR
  126. *STAT-INC SMSTAT
  127. *STAT      POINTEUR MSTEMP.MSTAT
  128. *
  129.       INTEGER IMPR,IRET
  130. *
  131.       INTEGER NIUNIQ,NIPRI
  132.       INTEGER NTOTPO,NPPRI,NELC
  133. *
  134. * Executable statements
  135. *
  136.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans promat.eso'
  137. *STAT      CALL INMSTA(MSTAT,0)
  138. * Repérage global des inconnues : ICOGLO (LISTMOTS)
  139. * Noms des inconnues primales et duales de B et C exprimées
  140. * dans ce repérage : IC{PRI,DUA}{B,C}
  141. * (Eventuellement, si CHPOD.NE.0) :
  142. * Noms des inconnues de CHPOD dans ce repérage
  143. * In REPICO : SEGINI ICOGLO
  144. * In REPICO : SEGINI ICPRIB
  145. * In REPICO : SEGINI ICDUAB
  146. * In REPICO : SEGINI ICPRIC
  147. * In REPICO : SEGINI ICDUAC
  148. * In REPICO : SEGINI ICPRID
  149. *STAT      CALL INMSTA(MSTEMP,0)
  150. *      WRITE(IOIMP,*) 'repico'
  151.       CALL REPICO(IMATB,IMATC,CHPOD,
  152.      $     ICOGLO,ICPRIB,ICDUAB,ICPRIC,ICDUAC,ICPRID,
  153.      $     IMPR,IRET)
  154.       IF (IRET.NE.0) GOTO 9999
  155. *      SEGPRT,ICOGLO
  156. *STAT      CALL PRMSTA('    repico',MSTEMP,1)
  157. *STAT      CALL SUMSTA(MSTEMP,0)
  158.       SEGACT ICOGLO
  159.       NIUNIQ=ICOGLO.MOTS(/2)
  160.       SEGDES ICOGLO
  161. * Construction de ICOPRI (LISTENTI), liste des inconnues
  162. * appartenant à la fois à ICPRIB, ICPRIC et ICPRID
  163. * In INCCOM : SEGINI ICOPRI
  164. *STAT      CALL INMSTA(MSTEMP,0)
  165. *      WRITE(IOIMP,*) 'inccom'
  166.       CALL INCCOM(ICPRIB,ICPRIC,ICPRID,NIUNIQ,
  167.      $     ICOPRI,
  168.      $     IMPR,IRET)
  169.       IF (IRET.NE.0) GOTO 9999
  170. *      SEGPRT,ICOPRI
  171. *STAT      CALL PRMSTA('    inccom',MSTEMP,1)
  172. *STAT      CALL SUMSTA(MSTEMP,0)
  173. * Si ICOPRI est vide, on sort prématurément
  174.       SEGACT ICOPRI
  175.       NIPRI=ICOPRI.LECT(/1)
  176.       SEGDES ICOPRI
  177.       IF (NIPRI.EQ.0) THEN
  178. *!         write(ioimp,*) 'pas d''inconnues communes'
  179. *         SEGINI ICOPRI
  180. *         SEGINI ICPRID
  181. *         SEGINI ICDUAC
  182. *         SEGINI ICPRIC (exception)
  183. *         SEGINI ICDUAB
  184. *         SEGINI ICPRIB
  185. *         SEGINI ICOGLO
  186.          SEGSUP ICOPRI
  187.          SEGSUP ICPRID
  188.          SEGSUP ICDUAC
  189.          SEGSUP ICPRIC
  190.          SEGSUP ICDUAB
  191.          SEGSUP ICPRIB
  192.          SEGSUP ICOGLO
  193.          GOTO 9998
  194.       ENDIF
  195. * Sinon, on construit KRIPRI où on a repéré les inconnues de ICOPRI
  196. * dans le segment des inconnues globales
  197. * In KRIPEE : SEGINI KRIPRI
  198. *STAT      CALL INMSTA(MSTEMP,0)
  199. *      WRITE(IOIMP,*) 'kripee'
  200.       CALL KRIPEE(ICOPRI,NIUNIQ,
  201.      $     KRIPRI,
  202.      $     IMPR,IRET)
  203.       IF (IRET.NE.0) GOTO 9999
  204. *      SEGPRT,KRIPRI
  205. *STAT      CALL PRMSTA('    kripee',MSTEMP,1)
  206. *STAT      CALL SUMSTA(MSTEMP,0)
  207. *STAT      CALL PRMSTA('  Inc. primales communes',MSTAT,1)
  208.       SEGSUP ICOPRI
  209. * Construction du maillage des points communs au maillage
  210. * primal de B, au maillage primal de C et au maillage sous-tendant
  211. * CHPOD (si CHPOD.NE.0)
  212.       NTOTPO=nbpts
  213. * In MELCOM : SEGINI MAIPRI
  214. *STAT      CALL INMSTA(MSTEMP,0)
  215. *      WRITE(IOIMP,*) 'melcom'
  216.       CALL MELCOM(MPRIB,CHPOD,MPRIC,
  217.      $     MAIPRI,
  218.      $     IMPR,IRET)
  219.       IF (IRET.NE.0) GOTO 9999
  220. *STAT      CALL PRMSTA('    melcom',MSTEMP,1)
  221. *STAT      CALL SUMSTA(MSTEMP,0)
  222. * Si MAIPRI est vide, on sort prématurément
  223.       SEGACT MAIPRI
  224.       NPPRI=MAIPRI.NUM(/2)
  225.       SEGDES MAIPRI
  226.       IF (NPPRI.EQ.0) THEN
  227. *!         write(ioimp,*) 'pas de points communs'
  228. *         SEGINI MAIPRI
  229. *         SEGINI KRIPRI
  230. *         SEGINI ICPRID
  231. *         SEGINI ICDUAC (exception)
  232. *         SEGINI ICPRIC
  233. *         SEGINI ICDUAB
  234. *         SEGINI ICPRIB
  235. *         SEGINI ICOGLO
  236.          SEGSUP MAIPRI
  237.          SEGSUP KRIPRI
  238.          SEGSUP ICPRID
  239.          SEGSUP ICDUAC
  240.          SEGSUP ICPRIC
  241.          SEGSUP ICDUAB
  242.          SEGSUP ICPRIB
  243.          SEGSUP ICOGLO
  244.          GOTO 9998
  245.       ENDIF
  246. * Sinon, on construit le segment de repérage dans MAIPRI
  247. * In KRIPME : SEGINI KRMPRI
  248. *STAT      CALL INMSTA(MSTEMP,0)
  249. *      WRITE(IOIMP,*) 'kripme'
  250.       CALL KRIPME(MAIPRI,NTOTPO,
  251.      $     KRMPRI,
  252.      $     IMPR,IRET)
  253.       IF (IRET.NE.0) GOTO 9999
  254. *STAT      CALL PRMSTA('    kripme',MSTEMP,1)
  255. *STAT      CALL SUMSTA(MSTEMP,0)
  256. *STAT      CALL PRMSTA('  Points primaux communs',MSTAT,1)
  257.       SEGSUP MAIPRI
  258. *
  259. * Traitement des inconnues
  260. *
  261. * On repère les éléments de ICPRIB qui sont dans ICOPRI
  262. * In RPENEN : SEGINI LNBMEB
  263. *STAT      CALL INMSTA(MSTEMP,0)
  264. *      WRITE(IOIMP,*) 'rpenen1'
  265.       CALL RPENEN(ICPRIB,KRIPRI,
  266.      $     LNBMEB,
  267.      $     IMPR,IRET)
  268.       IF (IRET.NE.0) GOTO 9999
  269. * On repère les éléments de ICPRIC qui sont dans ICOPRI
  270. * In RPENEN : SEGINI LNBMEC
  271. *      WRITE(IOIMP,*) 'rpenen2'
  272.       CALL RPENEN(ICPRIC,KRIPRI,
  273.      $     LNBMEC,
  274.      $     IMPR,IRET)
  275.       IF (IRET.NE.0) GOTO 9999
  276. *      SEGPRT,LNBMEB
  277. *      SEGPRT,LNBMEC
  278. *STAT      CALL PRMSTA('    rpenen*2',MSTEMP,1)
  279. *STAT      CALL SUMSTA(MSTEMP,0)
  280. * Extraction des inconnues qui vont servir
  281. * In EXINCS : SEGINI JCPRIB
  282. * In EXINCS : SEGINI JCDUAB
  283. * In EXINCS : SEGINI JCPRIC
  284. * In EXINCS : SEGINI JCDUAC
  285. *STAT      CALL INMSTA(MSTEMP,0)
  286. *      WRITE(IOIMP,*) 'exincs'
  287.       CALL EXINCS(ICDUAB,ICPRIB,ICPRIC,ICDUAC,
  288.      $     LNBMEB,LNBMEC,
  289.      $     JCDUAB,JCPRIB,JCPRIC,JCDUAC,
  290.      $     IMPR,IRET)
  291.       IF (IRET.NE.0) GOTO 9999
  292. *STAT      CALL PRMSTA('    exincs',MSTEMP,1)
  293. *STAT      CALL SUMSTA(MSTEMP,0)
  294.       SEGSUP ICDUAC
  295.       SEGSUP ICPRIC
  296.       SEGSUP ICDUAB
  297.       SEGSUP ICPRIB
  298. * On crée la liste indexée de correspondance :
  299. * une inconnue de ICOPRI -> n°s(IBMEs) matrice C tels que
  300. *                        JCPRIC(IBME)=ICOPRI
  301. * In RPENLE : SEGINI LIPNMC
  302. *STAT      CALL INMSTA(MSTEMP,0)
  303. *      WRITE(IOIMP,*) 'rpenle'
  304.       CALL RPENLE(JCPRIC,KRIPRI,NIPRI,
  305.      $     LIPNMC,
  306.      $     IMPR,IRET)
  307.       IF (IRET.NE.0) GOTO 9999
  308. *      SEGPRT,JCPRIC
  309. *      SEGPRT,LIPNMC
  310. *STAT      CALL PRMSTA('    rpenle',MSTEMP,1)
  311. *STAT      CALL SUMSTA(MSTEMP,0)
  312. * On crée la liste indexée de correspondance :
  313. * n°(NBME) matrice B -> n°s(NBMEs) matrice C ayant la même inconnue
  314. * primale
  315. * In MKNBNC : SEGINI LINBNC
  316. *STAT      CALL INMSTA(MSTEMP,0)
  317. *      SEGPRT,JCPRIB
  318. *      WRITE(IOIMP,*) 'mknbnc'
  319.       CALL MKNBNC(JCPRIB,LIPNMC,KRIPRI,
  320.      $     LINBNC,
  321.      $     IMPR,IRET)
  322.       IF (IRET.NE.0) GOTO 9999
  323. *STAT      CALL PRMSTA('    mknbnc',MSTEMP,1)
  324. *STAT      CALL SUMSTA(MSTEMP,0)
  325. * On construit la liste des inconnues primales de CD-1Bt
  326. * In MIPCDB : SEGINI ICPCDB
  327. *STAT      CALL INMSTA(MSTEMP,0)
  328. *      WRITE(IOIMP,*) 'mipcdb'
  329.       CALL MIPCDB(JCDUAB,NIUNIQ,
  330.      $     ICPCDB,
  331.      $     IMPR,IRET)
  332.       IF (IRET.NE.0) GOTO 9999
  333. *STAT      CALL PRMSTA('    mipcdb',MSTEMP,1)
  334. *STAT      CALL SUMSTA(MSTEMP,0)
  335. * On construit la liste indexée à la précédente des
  336. * inconnues duales de CD-1Bt.
  337. * In MIDCDB : SEGINI ICDCDB
  338. *STAT      CALL INMSTA(MSTEMP,0)
  339. *      WRITE(IOIMP,*) 'midcdb'
  340.       CALL MIDCDB(ICPCDB,JCDUAB,LINBNC,JCDUAC,NIUNIQ,
  341.      $     ICDCDB,
  342.      $     IMPR,IRET)
  343.       IF (IRET.NE.0) GOTO 9999
  344. *STAT      CALL PRMSTA('    midcdb',MSTEMP,1)
  345. *STAT      CALL SUMSTA(MSTEMP,0)
  346. *STAT      CALL PRMSTA('  Traitement des inconnues',MSTAT,1)
  347.       SEGSUP LINBNC
  348. *
  349. * Traitement des maillages
  350. *
  351. * Construction de la liste des éléments du maillage primal de B
  352. * qui contiennent un point de MAIPRI.
  353. * In RPELEN : SEGINI LELEMB
  354. *STAT      CALL INMSTA(MSTEMP,0)
  355. *      WRITE(IOIMP,*) 'rpelen1'
  356.       CALL RPELEN(MPRIB,KRMPRI,
  357.      $     LELEMB,
  358.      $     IMPR,IRET)
  359.       IF (IRET.NE.0) GOTO 9999
  360. *      SEGPRT,LELEMB
  361. * Construction de la liste des éléments du maillage primal de C
  362. * qui contiennent un point de MAIPRI.
  363. * In RPELEN : SEGINI LELEMC
  364. *      WRITE(IOIMP,*) 'rpelen2'
  365.       CALL RPELEN(MPRIC,KRMPRI,
  366.      $     LELEMC,
  367.      $     IMPR,IRET)
  368.       IF (IRET.NE.0) GOTO 9999
  369. *      SEGPRT,LELEMC
  370. *STAT      CALL PRMSTA('    rpelen*2',MSTEMP,1)
  371. *STAT      CALL SUMSTA(MSTEMP,0)
  372. * Extraction des éléments des MELEMEs qui vont servir et
  373. * transformation en listes indexées plus faciles à manipuler
  374. * In ML2LIE : SEGINI LMDUAB
  375. * In ML2LIE : SEGINI LMPRIB
  376. * In ML2LIE : SEGINI LMPRIC
  377. * In ML2LIE : SEGINI LMDUAC
  378. *STAT      CALL INMSTA(MSTEMP,0)
  379. *      WRITE(IOIMP,*) 'ml2lie'
  380.       CALL ML2LIE(MDUAB,MPRIB,MPRIC,MDUAC,
  381.      $     LELEMB,LELEMC,
  382.      $     LMDUAB,LMPRIB,LMPRIC,LMDUAC,
  383.      $     IMPR,IRET)
  384.       IF (IRET.NE.0) GOTO 9999
  385. *STAT      CALL PRMSTA('    ml2lie',MSTEMP,1)
  386. *STAT      CALL SUMSTA(MSTEMP,0)
  387. * On crée la liste indexée de correspondance :
  388. * un point de MAIPRI -> n°s des éléments de LMPRIC qui contiennent
  389. *                       ce point
  390. * In REPELLE : SEGINI LIPNLC
  391. *STAT      CALL INMSTA(MSTEMP,0)
  392. *      WRITE(IOIMP,*) 'rpelle'
  393.       CALL RPELLE(LMPRIC,KRMPRI,NPPRI,
  394.      $     LIPNLC,
  395.      $     IMPR,IRET)
  396.       IF (IRET.NE.0) GOTO 9999
  397. *STAT      CALL PRMSTA('    rpelle',MSTEMP,1)
  398. *STAT      CALL SUMSTA(MSTEMP,0)
  399. * On crée la liste indexée de correspondance :
  400. * n° matrice élémentaire B -> n°s matrices élémentaires C
  401.       SEGACT LMPRIC
  402.       NELC=LMPRIC.IDX(/1)-1
  403.       SEGDES LMPRIC
  404. * In MKLBLC : SEGINI LILBLC
  405. *STAT      CALL INMSTA(MSTEMP,0)
  406. *      WRITE(IOIMP,*) 'mklblc'
  407.       CALL MKLBLC(LMPRIB,KRMPRI,LIPNLC,NELC,
  408.      $     LILBLC,
  409.      $     IMPR,IRET)
  410.       IF (IRET.NE.0) GOTO 9999
  411. *STAT      CALL PRMSTA('    mklblc',MSTEMP,1)
  412. *STAT      CALL SUMSTA(MSTEMP,0)
  413.       SEGSUP LIPNLC
  414. * On construit la liste des éléments primaux de CD-1Bt.
  415. * C'est déjà fait, c'est LMDUAB
  416.       LMPCDB=LMDUAB
  417. * On construit la liste des éléments duaux de CD-1Bt.
  418. * In MLDCDB : SEGINI LMDCDB
  419. *STAT      CALL INMSTA(MSTEMP,0)
  420. *      WRITE(IOIMP,*) 'mldcdb'
  421.       CALL MLDCDB(LILBLC,LMDUAC,NTOTPO,
  422.      $     LMDCDB,
  423.      $     IMPR,IRET)
  424.       IF (IRET.NE.0) GOTO 9999
  425. *STAT      CALL PRMSTA('    mldcdb',MSTEMP,1)
  426. *STAT      CALL SUMSTA(MSTEMP,0)
  427. *STAT      CALL PRMSTA('  Traitement des maillages',MSTAT,1)
  428. *
  429. * Traitement (éventuel) du chpoint
  430. *
  431. * In CP2LR : SEGINI LCHPOD
  432. * In CP2LR : SEGINI LCHPOD.LISLR(*)
  433. * Attention, 2 segments supp. sont créés du fait du fonctionnement de
  434. * DTCHPO.
  435. *STAT      CALL INMSTA(MSTEMP,0)
  436. *      WRITE(IOIMP,*) 'cp2lr'
  437.       CALL CP2LR(CHPOD,
  438.      $     ICPRID,ICOGLO,KRIPRI,NIPRI,
  439.      $     KRMPRI,NPPRI,
  440.      $     LCHPOD,
  441.      $     IMPR,IRET)
  442.       IF (IRET.NE.0) GOTO 9999
  443. *STAT      CALL PRMSTA('    cp2lr ',MSTEMP,1)
  444. *STAT      CALL SUMSTA(MSTEMP,0)
  445. *STAT      CALL PRMSTA('  Traitement du chpoint',MSTAT,1)
  446.       IF (ICPRID.NE.0) THEN
  447.          SEGSUP ICPRID
  448.       ENDIF
  449. *
  450. * Traitement des matrices
  451. *
  452. * Extraction des éléments des IMATRIs qui vont servir et
  453. * transformation en listes indexées plus faciles à manipuler
  454. * In MA2LIR : SEGINI LMATRB
  455. * In MA2LIR : SEGINI LMATRB.LISLI(*)
  456. * In MA2LIR : SEGINI LMATRC
  457. * In MA2LIR : SEGINI LMATRC.LISLI(*)
  458. *STAT      CALL INMSTA(MSTEMP,0)
  459. *      WRITE(IOIMP,*) 'ma2lir'
  460.       CALL MA2LIR(IMATB,IMATC,
  461.      $     LNBMEB,LNBMEC,LELEMB,LELEMC,
  462.      $     LMATRB,LMATRC,
  463.      $     IMPR,IRET)
  464.       IF (IRET.NE.0) GOTO 9999
  465. *      SEGPRT,LMATRB
  466. *      SEGPRT,LMATRC
  467. *STAT      CALL PRMSTA('    ma2lir',MSTEMP,1)
  468. *STAT      CALL SUMSTA(MSTEMP,0)
  469. *STAT      CALL PRMSTA('  Traitement des matrices',MSTAT,1)
  470.       SEGSUP LELEMC
  471.       SEGSUP LELEMB
  472.       SEGSUP LNBMEC
  473.       SEGSUP LNBMEB
  474. * Produit des matrices stockées sous forme de listes indexées
  475. * In MA2LIR : SEGINI LMACDB
  476. * In MA2LIR : SEGINI LMACDB.LISLI(*)
  477. *STAT      CALL INMSTA(MSTEMP,0)
  478. *      WRITE(IOIMP,*) 'prolis'
  479.       CALL PROLIS(JCDUAB,JCPRIB,JCPRIC,JCDUAC,
  480.      $     LIPNMC,       KRIPRI,
  481.      $     LMDUAB,LMPRIB,LMPRIC,LMDUAC,
  482.      $            LILBLC,KRMPRI,
  483.      $     LCHPOD,LMATRB,LMATRC,
  484.      $     ICPCDB,ICDCDB,NIUNIQ,
  485.      $     LMPCDB,LMDCDB,NTOTPO,
  486.      $     LMACDB,
  487.      $     IMPR,IRET)
  488.       IF (IRET.NE.0) GOTO 9999
  489. *      WRITE(IOIMP,*) 'apres prolis'
  490. *STAT      CALL PRMSTA('    prolis',MSTEMP,1)
  491. *STAT      CALL SUMSTA(MSTEMP,0)
  492. *STAT      CALL PRMSTA('  On effectue le produit',MSTAT,1)
  493.       SEGACT LMATRC*MOD
  494.       SEGSUP LMATRC.LISLI(*)
  495. *      SEGDES LMATRC
  496.       SEGSUP LMATRC
  497.       SEGACT LMATRB*MOD
  498.       SEGSUP LMATRB.LISLI(*)
  499. *      SEGDES LMATRB
  500.       SEGSUP LMATRB
  501.       IF (LCHPOD.NE.0) THEN
  502.          SEGACT LCHPOD*MOD
  503.          SEGSUP LCHPOD.LISLR(*)
  504. *      SEGDES LCHPOD
  505.          SEGSUP LCHPOD
  506.       ENDIF
  507.       SEGSUP LILBLC
  508.       SEGSUP LMDUAC
  509.       SEGSUP LMPRIC
  510.       SEGSUP LMPRIB
  511.       SEGSUP LIPNMC
  512.       SEGSUP JCDUAC
  513.       SEGSUP JCPRIC
  514.       SEGSUP JCDUAB
  515.       SEGSUP JCPRIB
  516.       SEGSUP KRMPRI
  517.       SEGSUP KRIPRI
  518. * Transformation des listes indexées résultats en maillages et en
  519. * matrices.
  520. *STAT      CALL INMSTA(MSTEMP,0)
  521. *      WRITE(IOIMP,*) 'li2mas'
  522.       CALL LI2MAS(ICPCDB,ICDCDB,ICOGLO,
  523.      $     LMPCDB,LMDCDB,LMACDB,
  524.      $     MPCDB,MDCDB,IMTCDB,
  525.      $     IMPR,IRET)
  526.       IF (IRET.NE.0) GOTO 9999
  527. *STAT      CALL PRMSTA('  Traitement du produit',MSTAT,1)
  528. *STAT      CALL PRMSTA('    li2mas',MSTEMP,1)
  529. *STAT      CALL SUMSTA(MSTEMP,0)
  530.       SEGACT LMACDB*MOD
  531.       SEGSUP LMACDB.LISLI(*)
  532. *      SEGDES LMACDB
  533.       SEGSUP LMACDB
  534.       SEGSUP LMDCDB
  535.       SEGSUP LMPCDB
  536.       SEGSUP ICDCDB
  537.       SEGSUP ICPCDB
  538.       SEGSUP ICOGLO
  539. *STAT      CALL SUMSTA(MSTAT,0)
  540. *
  541. * Normal termination
  542. *
  543.       IRET=0
  544.       RETURN
  545. *
  546. * Format handling
  547. *
  548. *
  549. * Error handling
  550. *
  551. * Pas une erreur proprement dite, mais il n'y avait rien à multiplier
  552.  9998 CONTINUE
  553.       MPCDB=0
  554.       MDCDB=0
  555.       IMTCDB=0
  556.       IRET=0
  557.       RETURN
  558.  9999 CONTINUE
  559.       IRET=1
  560.       WRITE(IOIMP,*) 'An error was detected in subroutine promat'
  561.       RETURN
  562. *
  563. * End of subroutine PROMAT
  564. *
  565.       END
  566.  
  567.  
  568.  
  569.  
  570.  
  571.  
  572.  
  573.  
  574.  
  575.  
  576.  

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