Télécharger la plaquette Cast3M


fr en

Télécharger kres2.eso

Retour à la liste

Numérotation des lignes : 

kres2

  1. C KRES2     SOURCE    GOUNAND   25/03/24    21:15:04     12216          
  2.       SUBROUTINE KRES2()
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C*************************************************************************
  6. C     Operateur KRES
  7. C
  8. C     OBJET   : Resoud l'equation AX=B par différentes méthodes
  9. C               * directe (factorisation Choleski)
  10. C               * itérative (Gradient conjugué, BiCGSTAB,
  11. C                 GMRES(m)) avec différents préconditionneurs
  12. C                 diagonal (Jacobi), D-ILU, ILU(0) (Choleski
  13. C                 incomplet), MILU(0)
  14. C     SYNTAXE :   CHPO3 = KRES MA1 'TYPI' TAB1
  15. C                                  'CLIM' CHPO1
  16. C                                  'SMBR' CHPO2
  17. C                                  'IMPR' VAL1   ;
  18. C     Voir la notice pour plus de précisions.
  19. C
  20. C***********************************************************************
  21. C APPELES          : KRES3, KRES4, KRES5
  22. C APPELES (E/S)    : LIROBJ, ECROBJ, ERREUR, LIRMOT, LIRENT, LIRTAB,
  23. C                    ACME, ACMO, ACMM, ACMF, ECMO, ECME
  24. C APPELES (UTIL.)  : QUETYP
  25. C APPELE PAR       : KOPS
  26. C***********************************************************************
  27. C***********************************************************************
  28. C HISTORIQUE : 26/10/98 : prise en compte du cas particulier
  29. C              où A est diagonale. C'est en fait assez pénible
  30. C              car on utilise le CHPOINT comme structure de
  31. C              données pour la matrice A et les vecteurs X,B,CLIM
  32. C HISTORIQUE : 09/02/99 : on peut utiliser le préconditionnement d'une
  33. C                         autre matrice que celle que l'on inverse
  34. C HISTORIQUE : 01/06/99 : on modifie la partie résolution itérative
  35. C                         en effet, lors de l'imposition des CL. de
  36. C                         Dirichlet, on changeait les valeurs de la
  37. C                         matrice Morse.
  38. C                         Ceci n'est pas bon lorsqu'on veut utiliser la
  39. C                         matrice assemblée pour plusieurs pas de temps.
  40. C                         On travaille maintenant sur une copie.
  41. C HISTORIQUE : 20/12/99 :  reprogrammation de l'assemblage
  42. C      Le nouvel assemblage n'est, pour l'instant effectif que
  43. C      lorsqu'une méthode itérative est sélectionnée (-> fabrication
  44. C      d'une matrice Morse). Le nouvel assemblage est plus performant
  45. C      (temps de calcul, utilisation de la mémoire) et plus général (cas
  46. C      particuliers à peu près supprimés) que le précédent.
  47. C HISTORIQUE : 05/01/00 : On ne supprime plus les 0.D0 de la matrice
  48. C      assemblée (cf. clmors appelé par melim). Ceci pour ne plus avoir
  49. C      perte éventuelle de symétrie de la matrice assemblée. Cela permet
  50. C      aussi de ne plus dupliquer la matrice assemblée.
  51. C HISTORIQUE : 13/01/00 : Mise en conformité du solveur direct avec le
  52. C      nouvel assemblage.
  53. C HISTORIQUE : 22/03/00 : Rajout des préconditionneurs ILUT
  54. C HISTORIQUE : 13/04/00 : Séparation Lecture des données
  55. C                                    Ecriture des résultats (kres2)
  56. C                         Assemblage            kres3
  57. C                         Méthode directe       kres4
  58. C                         Méthodes itératives   kres5
  59. C HISTORIQUE : 06/04/04 : Renumérotation (double mult.)
  60. C HISTORIQUE : 06/04/04 : Scaling
  61. C HISTORIQUE : 08/04/04 : ajout ILUTP
  62. C HISTORIQUE : 09/02/06 : ajout nb prod matrice vecteur (NMATVEC)
  63. C                         simplification du code
  64. C HISTORIQUE : 22/02/06 : Gros nettoyage au niveau de l'entrée des
  65. C                         arguments (Nouvelle syntaxe)
  66. C HISTORIQUE : 08/2011  : En vue de la suppression de l'objet MATRIK
  67. C                         on utilise l'assemblage de RESOU.
  68. C HISTORIQUE : 04/2019  : remplacement de NOEL par NELIM
  69. C     Idéalement, il faudrait reprendre ce que Pierre a fait dans
  70. C     RESOU dans les fiches 10[0,1]?? et avec MREM.En vue de la
  71. C     suppression de l'objet MATRIK
  72. C
  73. C***********************************************************************
  74. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  75. C en cas de modification de ce sous-programme afin de faciliter
  76. C la maintenance !
  77. C***********************************************************************
  78.  
  79. -INC PPARAM
  80. -INC CCOPTIO
  81. -INC SMLREEL
  82.       POINTEUR LRES.MLREEL
  83. -INC SMLENTI
  84.       POINTEUR LNMV.MLENTI
  85. -INC SMCHPOI
  86.       POINTEUR KCLIM.MCHPOI
  87.       POINTEUR KSMBR.MCHPOI
  88.       POINTEUR MCHINI.MCHPOI
  89.       POINTEUR MCHSOL.MCHPOI
  90. -INC SMTABLE
  91.       POINTEUR MTINV.MTABLE
  92.       POINTEUR KTIME.MTABLE
  93.       DIMENSION ITTIME(4)
  94.       CHARACTER*16 CHARI
  95. *  MATRIK est la matrice à inverser
  96. *  MAPREC est la matrice dont on utilise le préconditionnement
  97. *  MATASS est la matrice dont on utilise l'assemblage
  98. *         pour préconditionner celui de MATRIK
  100.       POINTEUR MAPREC.MATRIK
  101.       POINTEUR MATASS.MATRIK
  102. *STAT -INC SMSTAT
  103. C
  104.       CHARACTER*8 TYPE
  105. *     Paramètre m du GMRES(m)
  106.       INTEGER RESTRT
  107.       INTEGER ITER
  108.       REAL*8 BRTOL,RESID,RXMILU,RXILUP
  109. *
  110.       REAL*8 XLFIL,XDTOL
  111.       INTEGER KPREC
  112.       INTEGER NMATRI
  113.       INTEGER IP,KTYPI
  114.       INTEGER IMPINV,IIMPR
  115.       CHARACTER*4 MRENU,MMULAG
  116.       LOGICAL LRIG,LTIME,LDETR,LDEPE,LASRIG,LDMULT,LOGII
  117.       INTEGER IMPR,IRET
  118. C
  119. C  Lecture des arguments et mise à défaut des optionnels ()
  120. C
  121. C  MATRIK : La matrice lue en entrée au format MATRIK
  122. C  MTINV  : L'éventuelle table d'inversion (obsolète)
  123. C  IMPR   : Niveau d'impression solveur direct
  124. C  KCLIM  : Chpoint éventuel de conditions aux limites de Dirichlet
  125. C  KSMBR  : Chpoint second membre
  126. C  KTYPI  : Type de méthode de résolution
  127. C  MATASS : Matrice utilisée pour préconditionner l'assemblage
  128. C  MAPREC : Matrice utilisée pour préconditionner la construction du
  129. C           préconditionneur
  130. C  MRENU  : Type de renumérotation
  131. C  MMULAG : Placement des multiplicateurs de Lagrange
  132. C  ISCAL  : Scaling de la matrice
  133. C  IOUBL  : Oubli des matrices élémentaires ?
  134. C  IMPINV : Niveau d'impression solveur itératif
  135. C  MCHINI : Chpoint estimation de l'inconnue
  136. C  ITER   : Nombre maxi d'itérations à effectuer
  137. C  RESID  : Norme L2 maxi du résidu
  138. C  BRTOL  : Breakdown tolerance pour les méthodes de type Bi-CG
  139. C  IRSTRT : Paramètre m de redémarrage pour GMRES
  140. C  KPREC  : Type du préconditionneur
  141. C  RXMILU : Paramètre de relaxation pour MILU(0)
  142. C  RXILUP : Paramètre de filtre pour ILU(0)-PV
  143. C  XLFIL  : Paramètre de remplissage pour les préconditionneurs ILUT
  144. C  XDTOL  : Drop tolerance pour les préconditionneurs ILUT
  145. C  XSPIV  : Sensibilité du pivoting pour les préconditionneurs ILUTP
  146. C  LBCG   : le l dans BicgStab(l)
  147. C  ICALRS : façon de calculer le résidu
  148. C  METASS : Méthode d'assemblage
  149. C  LTIME  : construit une table avec des statistiques temporelles
  150. C           si vrai
  151. C  LDEPE  : élimine les dépendances si VRAI
  152. C           et matrice d'entrée RIGIDITE
  153. C  IDDOT  : 0 => utilisation du produit scalaire normal dans les
  154. C                méthodes itératives
  155. C           1 => utilisation du produit scalaire compensé
  156. *      IMPR=4
  157.  
  158.       IVALI=0
  159.       XVALI=0.D0
  160.       LOGII=.FALSE.
  161.       IRETI=0
  162.       XVALR=0.D0
  163. *inutile      IOBRE=0
  164.       IRETR=0
  165.  
  166.       IMPR=0
  167. *      WRITE(IOIMP,*) 'coucou kres2'
  168. *
  169. *STAT       CALL INMSTA(MSTAT,IMPR)
  170. *
  171.       CALL PRKRES(MATRIK,MTINV,IMPR,KCLIM,KSMBR,KTYPI,MATASS,MAPREC,
  172.      $     MRENU,MMULAG,ISCAL,INORMU,IOUBL,IMPINV,MCHINI,ITER,RESID
  173.      $     ,BRTOL,IRSTRT,KPREC,RXMILU,RXILUP,XLFIL,XDTOL,XSPIV,LBCG
  174.      $     ,ICALRS,METASS,LTIME,LDEPE,MRIGID,IDDOT,IMVEC,IORINC,IRET)
  175.       IF (IRET.NE.0) GOTO 9999
  176.       IMPR=MAX(IMPR,IMPINV)
  177. *
  178. * Préparation de la matrice et du second membre
  179. * suivant les cas
  180. *
  181. * LASRIG=.TRUE. on utilise l'assemblage de RESOU
  182. * LDMULT=.TRUE. on dédouble les multiplicateurs de Lagrange
  183. * LDEPE=.TRUE. On fait l'élimination des relations
  184.  
  185.       LASRIG=(METASS.EQ.6)
  186. *     Pour l'instant, il faut toujours dédoubler les multiplicateurs
  187. *     quand on assemble avec l'assemblage de RESO car le traitement des
  188. *     multiplicateurs dans ldmt1 l'impose (simple multiplicateur non
  189. *     prévu)
  190.       LDMULT=LASRIG
  191.       MRIGI0=MRIGID
  192. * Nouveau separm gère la non élimination avec NOEL
  193.       IF (LDEPE) then
  194. *     noel=0
  195.          nelim=1
  196.       ELSE
  197. *     noel=1
  198.          nelim=0
  199.       ENDIF
  200. *dbg      write(ioimp,*) 'LASRIG=',LASRIG
  201. *dbg      write(ioimp,*) 'LDMULT=',LDMULT
  202. *dbg      write(ioimp,*) 'LDEPE=',LDEPE,' NELIM=',NELIM
  203.  
  204.       IF (MRIGID.NE.0) THEN
  205. *old         IF (LDEPE) THEN
  206.          IF (IMPR.GT.1) THEN
  207.             WRITE(IOIMP,*)
  208.      $     '*** ELIMINATION DES MULTIPLICATEURS DE LAGRANGE (LX)  KRES6'
  209.          ENDIF
  210.             KSMBR0=KSMBR
  211. *old            CALL KRES6(MRIGID,KSMBR,IDEPE,
  212. *old     $           MRIGIC,KSMBRC,KSMBR0,KSMBR1)
  213.             CALL KRES6(MRIGID,KSMBR,LDMULT,NELIM,
  214.      $           MRIGIC,KSMBRC,KSMBR1)
  215.             IF (IERR.NE.0) RETURN
  216.             MRIGID=MRIGIC
  217.             KSMBR=KSMBRC
  218. *old         ENDIF
  219.          IF (LASRIG) THEN
  220.             IF (IMPR.GT.1) THEN
  221.                WRITE(IOIMP,*)
  222.      $              '*** ASSEMBLAGE RENUMEROTATION RESOU KRES8'
  223.             ENDIF
  224. * Gestion de la normalisation
  225.             NORICO=NORINC
  226.             NORIDO=NORIND
  227.             IF (ISCAL.EQ.0) THEN
  228.                NORINC=0
  229.                NORIND=0
  230.             ELSE
  231.                NORINC=-1
  232.                NORIND=0
  233.             ENDIF
  234. * Gestion de la renumérotation
  235.             NUCROO=NUCROU
  236.             IF (MRENU.EQ.'RIEN') THEN
  237.                NUCROU=-1
  238. * La renumérotation sera en fait Reverse Cuthill-McKee dans NUMOPT
  239.             ELSEIF (MRENU.EQ.'SLOA') THEN
  240.                NUCROU=1
  241. * La renumérotation sera en fait Nested Dissection dans NUMOPT
  242.             ELSEIF (MRENU.EQ.'GIPR'.OR.MRENU.EQ.'GIBA') THEN
  243.                NUCROU=2
  244.             ELSE
  245.                WRITE(IOIMP,*) 'MRENU=',MRENU
  246.                CALL ERREUR(5)
  247.                RETURN
  248.             ENDIF
  249.             CALL KRES8(MRIGID,KSMBR,INORMU,
  250.      $           KTYPI,ITER,RESID,ICALRS,IRSTRT,LBCG,BRTOL,IDDOT,IMVEC,
  251.      $           IORINC,
  252.      $           KPREC,RXMILU,RXILUP,XLFIL,XDTOL,XSPIV,
  253.      $           KTIME,LTIME,
  254.      $           MCHSOL,LRES,LNMV,ICVG,IMPR)
  255.             IF (IERR.NE.0) RETURN
  256. * Gestion de la normalisation
  257.             NORINC=NORICO
  258.             NORIND=NORIDO
  259.             NUCROU=NUCROO
  260.             IF (LTIME) CALL ECROBJ('TABLE   ',KTIME)
  261.             IF (MTINV.NE.0) THEN
  262.                CALL ECME(MTINV,'CVGOK',ICVG)
  263.                IF (LRES.NE.0) CALL ECMO(MTINV,'CONVINV','LISTREEL',LRES)
  264.                IF (LNMV.NE.0) CALL ECMO(MTINV,'NMATVEC','LISTENTI',LNMV)
  265.             ENDIF
  266. * On décondense si nécessaire
  267. *
  268. *            write (6,*) ' resou - mchsol '
  269. *            call ecchpo(mchsol,0)
  270. *            call mucpri(mchsol,mrigid,iresi)
  271. *            write (6,*) ' kres - iresi '
  272. *            call ecchpo(iresi,0)
  273. *      WRITE(IOIMP,*) 'Avant KRES7'
  274. *old            IF (MRIGI0.NE.0.AND.LDEPE) THEN
  275.             IF (MRIGI0.NE.0) THEN
  276.                MSOLC=MCHSOL
  277.                IDTARG=1
  278. * On détruit MSOLC dans KRES7
  279.                CALL KRES7(MSOLC,MRIGI0,KSMBR0,KSMBR1,IDTARG,
  280.      $              MCHSOL)
  281.                IF (IERR.NE.0) RETURN
  282.             ENDIF
  283.             CALL ECROBJ('CHPOINT ',MCHSOL)
  284.             RETURN
  285.          ELSE
  286.             IF (IMPR.GT.1) THEN
  287.                WRITE(IOIMP,*)
  288.      $              '*** TRANSFORMATION RIGIDITE -> MATRIK'
  289.                WRITE(IOIMP,*)
  290.      $              '*** ASSEMBLAGE RENUMEROTATION KRES2'
  291.             ENDIF
  292.             CALL ECROBJ('RIGIDITE',MRIGID)
  293.             CALL RIMA
  294.             IF (IERR.NE.0) GOTO 9999
  295.             CALL MACHI2(1)
  296.             IF (IERR.NE.0) GOTO 9999
  297.             CALL LIROBJ('MATRIK',MATRIK,1,IRET)
  298.             IF(IRET.EQ.0) GOTO 9999
  299.  
  300. * Changement des noms d'inconnues du second membre
  301.             IF (KSMBR.NE.0) THEN
  302.                CALL ECROBJ('CHPOINT ',KSMBR)
  303.                CALL MACHI2(1)
  304.                CALL LIROBJ('CHPOINT ',KSMBR,1,IRET)
  305.                IF (IRET.EQ.0) GOTO 9999
  306.             ENDIF
  307.          ENDIF
  308. *         write (6,*) ' le vecteur  2'
  309. *         call ecchpo(ksmbr,0)
  310. *         write (6,*) ' la matrice  2'
  311. *         call ecrent(5)
  312. *         call ecmatk(matrik)
  313.       ENDIF
  314. *
  315.       SEGACT MATRIK
  316.       NMATRI=IRIGEL(/2)
  317.       IF(NMATRI.EQ.0)THEN
  318. C% Résolution impossible : la matrice de RIGIDITE est vide
  319.          CALL ERREUR(727)
  320.          RETURN
  321.       ENDIF
  322.       SEGDES MATRIK
  323.       IF (MATASS.EQ.0) MATASS=MATRIK
  324.       IF (MAPREC.EQ.0) MAPREC=MATRIK
  325. *      WRITE(IOIMP,*) 'Sortie de prkres'
  326. *      WRITE(IOIMP,*) 'IOUBL=',IOUBL
  327. C
  328.       IF (LTIME) THEN
  329.          CALL CRTABL(KTIME)
  330.          call timespv(ittime,oothrd)
  331.          ITI1=(ITTIME(1)+ITTIME(2))/10
  332.       ELSE
  333.          KTIME=0
  334.       ENDIF
  335. *STAT       CALL PRMSTA('Lectures',MSTAT,IMPR)
  336. *
  337. C
  338. C Assemblage proprement dit
  339. C
  340.       IIMPR=0
  341.       CALL KRES3(MATRIK,MATASS,MRENU,MMULAG,METASS,
  342.      $     KTIME,LTIME,
  343.      $     IIMPR,IRET)
  344. * Gestion du CTRL-C
  345.       if (ierr.NE.0) return
  346.       IF (IRET.NE.0) GOTO 9999
  347. *!      WRITE(IOIMP,*) 'Aprés assemblage'
  348. *!      CALL ECRENT(5)
  349. *!      CALL ECROBJ('MATRIK  ',MATRIK)
  350. *!      CALL PRLIST
  351.       IF (LTIME) THEN
  352.          call timespv(ittime,oothrd)
  353.          ITI2=(ITTIME(1)+ITTIME(2))/10
  354.       ENDIF
  355. *STAT       CALL PRMSTA('Assemblage',MSTAT,IMPR)
  356. *
  357. * "Oubli" des valeurs des matrice élémentaires
  358. * On met les tableaux de LIZAFM à 0 => à MENAGE de les supprimmer
  359. * si besoin est.
  360. *
  361.       IOUBD=MOD(IOUBL,10)
  362. *!      WRITE(IOIMP,*) 'IOUBD=',IOUBD
  363.       IF (IOUBD.EQ.1) THEN
  364.          CALL OUBIMA(MATRIK,IMPR,IRET)
  365.          IF (IRET.NE.0) GOTO 9999
  366.          IF (IMPR.GT.2) THEN
  367.             WRITE(IOIMP,*) 'Oubli des mat. elem.'
  368.          ENDIF
  369.       ELSEIF (IOUBD.EQ.2) THEN
  370.          call ooohor(0)
  371.          SEGACT MATRIK*MOD
  372.          LDETR=.FALSE.
  373.          NMATE=IRIGEL(/2)
  374.          DO IMATE=1,NMATE
  375.             IMATRI=IRIGEL(4,IMATE)
  376.             SEGACT IMATRI*MOD
  377.             NSOUM =LIZAFM(/1)
  378.             NTOTIN=LIZAFM(/2)
  379.             DO ITOTIN=1,NTOTIN
  380.                DO ISOUM=1,NSOUM
  381.                   IZAFM=LIZAFM(ISOUM,ITOTIN)
  382.                   IF (IZAFM.NE.0) THEN
  383.                      LDETR=.TRUE.
  384.                      SEGSUP IZAFM
  385.                      LIZAFM(ISOUM,ITOTIN)=0
  386.                   ENDIF
  387.                ENDDO
  388.             ENDDO
  389.             SEGDES IMATRI
  390.          ENDDO
  391.          IF (IMPR.GT.2.AND.LDETR) THEN
  392.             WRITE(IOIMP,*) 'Destruction des mat. elem.'
  393.          ENDIF
  394.       ELSEIF (IOUBD.NE.0) THEN
  395.          WRITE(IOIMP,*) 'IOUBL=',IOUBL, ' non prevu'
  396.          GOTO 9999
  397.       ENDIF
  398. *STAT       CALL PRMSTA('Oubli',MSTAT,IMPR)
  399. *!      WRITE(IOIMP,*) 'Aprés oubli'
  400. C
  401. C Méthode directe
  402. C
  403.       IF (KTYPI.EQ.1) THEN
  404.          CALL KRES4(MATRIK,KCLIM,KSMBR,
  405.      $        ISCAL,
  406.      $        MCHSOL,
  407.      $        IMPR,IRET)
  408.          if (ierr.ne.0) return
  409.          IF (IRET.NE.0) GOTO 9999
  410. *STAT       CALL PRMSTA('Methode directe',MSTAT,IMPR)
  411. C
  412. C Méthodes itératives
  413. C
  414.       ELSE
  415. C
  416.          CALL KRES5(MATRIK,KCLIM,KSMBR,KTYPI,
  417.      $        MCHINI,ITER,RESID,
  418.      $        BRTOL,IRSTRT,LBCG,ICALRS,
  419.      $        MAPREC,KPREC,
  420.      $        RXMILU,RXILUP,XLFIL,XDTOL,XSPIV,
  421.      $        ISCAL,
  422.      $        KTIME,LTIME,IDDOT,IMVEC,IORINC,
  423.      $        MCHSOL,LRES,LNMV,ICVG,
  424.      $        IMPR,IRET)
  425.          if (ierr.ne.0) return
  426.          IF (IRET.NE.0) GOTO 9999
  427. *STAT       CALL PRMSTA('Methode iterative',MSTAT,IMPR)
  428.          IF (MTINV.NE.0) THEN
  429.             CALL ECME(MTINV,'CVGOK',ICVG)
  430.             CALL ECMO(MTINV,'CONVINV','LISTREEL',LRES)
  431.             CALL ECMO(MTINV,'NMATVEC','LISTENTI',LNMV)
  432.          ENDIF
  433.       ENDIF
  434.       IF (LTIME) THEN
  435.          call timespv(ittime,oothrd)
  436.          ITI3=(ITTIME(1)+ITTIME(2))/10
  437.          CHARI='KRES ASS+RENU'
  438.          CALL ECCTAB(KTIME,'MOT     ',IVALI,XVALI,CHARI,LOGII,IRETI,
  439.      $                     'ENTIER  ',ITI2-ITI1,XVALR,CHARR,LOGIR,IRETR)
  440.          CHARI='KRES PRE+RESO'
  441.          CALL ECCTAB(KTIME,'MOT     ',IVALI,XVALI,CHARI,LOGII,IRETI,
  442.      $                     'ENTIER  ',ITI3-ITI2,XVALR,CHARR,LOGIR,IRETR)
  443.          CHARI='KRES TOTAL   '
  444.          CALL ECCTAB(KTIME,'MOT     ',IVALI,XVALI,CHARI,LOGII,IRETI,
  445.      $                     'ENTIER  ',ITI3-ITI1,XVALR,CHARR,LOGIR,IRETR)
  446.          SEGDES KTIME
  447.          CALL ECROBJ('TABLE   ',KTIME)
  448.       ENDIF
  449.       IOUBE=IOUBL/10
  450. *!      WRITE(IOIMP,*) 'IOUBE=',IOUBE
  451.       IF (IOUBE.GE.1) THEN
  452.          call ooohor(0)
  453.          SEGACT MATRIK*MOD
  454.          IF (IOUBE.EQ.2) THEN
  455.             PMORS=KIDMAT(4)
  456.             IF (PMORS.NE.0) THEN
  457.                IF (IMPR.GT.2) THEN
  458.                   WRITE(IOIMP,*) 'Destruction du profil morse'
  459.                ENDIF
  460.                SEGSUP PMORS
  461.                KIDMAT(4)=0
  462.             ENDIF
  463.          ENDIF
  464.          IZA=KIDMAT(5)
  465.          IF (IZA.NE.0) THEN
  466.             IF (IMPR.GT.2) THEN
  467.                WRITE(IOIMP,*) 'Destruction des valeurs morses'
  468.             ENDIF
  469.             SEGSUP IZA
  470.             KIDMAT(5)=0
  471.          ENDIF
  472.          PMORS=KIDMAT(6)
  473.          IF (PMORS.NE.0) THEN
  474.             IF (IMPR.GT.2) THEN
  475.                WRITE(IOIMP,*) 'Destruction du profil du precon'
  476.             ENDIF
  477.             SEGSUP PMORS
  478.             KIDMAT(6)=0
  479.          ENDIF
  480.          IZA=KIDMAT(7)
  481.          IF (IZA.NE.0) THEN
  482.             IF (IMPR.GT.2) THEN
  483.                WRITE(IOIMP,*) 'Destruction des valeurs du precon'
  484.             ENDIF
  485.             SEGSUP IZA
  486.             KIDMAT(7)=0
  487.          ENDIF
  488.          SEGDES MATRIK
  489.       ELSEIF (IOUBE.NE.0) THEN
  490.          WRITE(IOIMP,*) 'IOUBL=',IOUBL, ' non prevu'
  491.          GOTO 9999
  492.       ENDIF
  493. *
  494. * On décondense si nécessaire
  495. *
  496. *            write (6,*) ' resou - mchsol '
  497. *            call ecchpo(mchsol,0)
  498. *            call mucpri(mchsol,mrigid,iresi)
  499. *            write (6,*) ' kres - iresi '
  500. *            call ecchpo(iresi,0)
  501. *      WRITE(IOIMP,*) 'Avant KRES7'
  502.       IF (MRIGI0.NE.0.AND.LDEPE) THEN
  503.          MSOLC=MCHSOL
  504. *         CALL KRES7(MRIGID,IDEPE,KSMBR0,KSMBR1,
  505. *     $        MSOLC,
  506. *     $        MCHSOL)
  507.          CALL KRES7(MSOLC,MRIGI0,KSMBR0,KSMBR1,1,
  508.      $        MCHSOL)
  509.          IF (IERR.NE.0) RETURN
  510.       ENDIF
  511.       CALL ECROBJ('CHPOINT ',MCHSOL)
  512. *STAT       CALL SUMSTA(MSTAT,IMPR)
  513. *
  514. * Normal termination
  515. *
  516.       RETURN
  517. *
  518. * Format handling
  519. *
  520. *
  521. * Error handling
  522. *
  523.  9999 CONTINUE
  524.       WRITE(IOIMP,*) 'An error was detected in kres2.eso'
  525. *  153 2
  526. * Opération illicite dans ce contexte
  527.       CALL ERREUR(153)
  528.       RETURN
  529. *
  530. * End of KRES2
  531. *
  532.       END
  533.  
  534.  

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