C MAPR      SOURCE    CB215821  24/07/17    21:15:09     11961          
      SUBROUTINE MAPR  (IRZTC)
      IMPLICIT INTEGER(I-N)
-INC PPARAM
-INC CCOPTIO
-INC SMBLOC
-INC CCNOYAU
-INC CCASSIS
      SEGMENT  ISEGP1
           INTEGER NOMMM(NIS)
      ENDSEGMENT
      SEGMENT  ISEGP2
           CHARACTER*(8) NTYP(NIS)
      ENDSEGMENT
      SEGMENT  ISEGP3
           INTEGER IOBLI(NIS)
      ENDSEGMENT
      SEGMENT  ISEGP4
           CHARACTER*(8) NSSTYP(NIS)
      ENDSEGMENT
      SEGMENT  ISEGP5
           INTEGER ILSSTY(NIS)
      ENDSEGMENT
      SEGMENT ISEG3
           INTEGER IRESAR(NIS)
      ENDSEGMENT
      SEGMENT IITRA
        integer ilevel(nlev),isino(nlev,nsi)
      ENDSEGMENT
      CHARACTER*(8) ICHA,CHAANC
      CHARACTER*(LONOM) CNOM,INOMP,NAM
      LOGICAL LOGI
      REAL*8 XRET
      DIMENSION LIRM(7)
      CHARACTER*4 MCLE(7), MAST(2)
      DATA  MCLE/'REPE','FIN ','FINP','FINM','SI','SINO','FINS'/
      DATA MAST/'*   ','/   '/
C  LECTURE DU NOM DE LA PROCEDURE
      if(iimpi.eq.1756)write(6,*)'avant appel quetyp lmnnno ',lmnnom
*      if(iimpi.eq.1876) write(6,*) ' mapr appel quetyp'
      CALL QUETYP (CHAANC ,0,IRETOU)
      if(iimpi.eq.1756) write(6,*)'mapr  retour quetyp',chaanc ,lmnnom
      IF(IRETOU.EQ.0) RETURN
      IF(IERR.NE.0) RETURN
        IF(CHAANC.EQ.'ENTIER  ') THEN
                CALL LIRENT ( II,1,IRETOU)
        ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
                CALL LIRREE(XRET,1,IRETOU)
        ELSEIF(CHAANC.EQ.'MOT     ') THEN
*      if(iimpi.eq.1876) write(6,*) ' mapr appel lircha'
                CALL LIRCHA(ICHA,1,IRETOU)
        ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
                CALL LIRLOG(LOGI,1,IRETOU)
        ELSE
                CALL LIROBJ(CHAANC,IRET,1,IRETOU)
        ENDIF
      CALL QUENOM ( CNOM)
       if(iimpi.eq.1756) write(6,*) ' mapr nom de la procedur' , CNOM
      IF(CNOM.EQ.' ') THEN
         CALL ERREUR(21  )
         RETURN
      ENDIF
      IF(IERR.NE.0) RETURN
      SEGINI MBLO1
         NVQTEM=20
         SEGINI ISSPOT
         MBLO1.ISPOTE=ISSPOT
         INOMP=CNOM
*         write(6,*) ' lmnnom avant nomobj'  , lmnnom
      CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
*          write(6,*) ' lmnnom apres nomobj'  , lmnnom
      moterr(1:8)=inomp
      IF(IIMPI.EQ.1754)WRITE(IOIMP,101) INOMP
 101  FORMAT(' DANS MAPR  NOM DE LA PROCEDURE  ' ,A24)
C      IARG=0
      MBLO1.MARGUM=0
      NIS=0
      SEGINI ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
C LECTURE DES ARGUMENTS ET DE LEURS TYPE ON LES METS DANS NOMMM ET NTYP
*  ESSAI PV ON VERROUILLE LES TEXTES PENDANT LA LECTURE DES ARGUMENTS
      INTEXT=1
   1  CONTINUE
      ICHA=' '
      CALL QUETYP (CHAANC ,0,IRETOU)
*     WRITE(6,FMT='('' CHAANC APRES QUETYP '',A8)') CHAANC
      IF(IRETOU.EQ.0) GOTO  2
      IF(IERR.NE.0) RETURN
        IF(CHAANC.EQ.'ENTIER  ') THEN
                CALL LIRENT ( II,1,IRETOU)
        ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
                CALL LIRREE(XRET,1,IRETOU)
        ELSEIF(CHAANC.EQ.'MOT     ') THEN
                CALL LIRCHA(ICHA,1,IRETOU)
        ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
                CALL LIRLOG(LOGI,1,IRETOU)
        ELSE
                CALL LIROBJ(CHAANC,IRET,1,IRETOU)
        ENDIF
*     WRITE(6,FMT='('' CHAANC AVANT QUENON '',A8)') CHAANC
      CALL QUENOM ( CNOM)
      DO 765 ILW=LONOM,1,-1
      IF(CNOM(ILW:ILW).NE.' ') GO TO 764
  765 CONTINUE
  764 LE=ILW
      CALL POSCHA(CNOM(1:LE),IPOSCH)
   2  CONTINUE
      IF(IRETOU.NE.0) THEN
        NIS=NOMMM(/1)+1
        SEGADJ ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
        NOMMM(NIS)=IPOSCH
        CALL LIRMOT(MAST,2,IAST,0)
          IF(IAST.NE.0) THEN
            CALL LIRCHA(ICHA,1,IRETOU)
            IF(IERR.NE.0) GO TO 1500
            NTYP(NIS)=ICHA
            NSSTYP(NIS)=' '
            ILSSTY(NIS)=0
            IF(IAST.EQ.1) THEN
               IOBLI(NIS)=1
            ELSE
               IOBLI(NIS)=0
            ENDIF
*      WRITE(6,FMT='('' ICHA TYPE DE L ARGUMENT '',A8)') ICHA
            IF(ICHA.EQ.'TABLE   ') THEN
               CHAANC=' '
               CALL QUETYP(CHAANC,0,IRETOU)
               IF(CHAANC.NE.'MOT     ') GO TO 1
               CALL LIRMOT(MAST,1,IAST,0)
               IF(IAST.EQ.0) GO TO 1
               ICHA=' '
               CALL LIRCHA(ICHA,1,IRETOU)
*      WRITE(6,FMT='('' ICHA TYPE DE LA TABLE   '',A8)') ICHA
               IF(IERR.NE.0) GO TO 1500
               NSSTYP(NIS)=ICHA
               ILSSTY(NIS)=IRETOU
            ENDIF
         ELSE
            NTYP(NIS)=' '
            NSSTYP=' '
            IOBLI(NIS)=1
            ILSSTY(NIS)=0
         ENDIF
         GO TO 1
      ENDIF
      NARG=NOMMM(/1)
*  FIN VERROUILLAGE TEXTES
      INTEXT=0
C  CREATION D'UN BLOC REPETE
      MTEM=MBLOC
      IF(MTXBL.NE.0)  THEN
         MTXBLC=MTXBL
         SEGDES MTXBLC
      ENDIF
      ISSPOT=ISPOTE
      SEGDES ISSPOT
      SEGDES MBLOC
      MBLOC=MBLO1
      MBLSUP=MTEM
      lmnpre=lmnnom
**     write(6,*) ' entree dans mapr mblsup mbloc:',mblsup,mbloc
      MDEOBJ=LMNNOM+1
      NBNOMM=1200
      NINST=1200
      IPVINN=3000
      SEGINI MTXBLC
      MTXBL=MTXBLC
      MBLPRO=0
      MBFONC=1
      MBCOUR=0
      MBCONT=1
C  ECRITURE DES ARGUMENTS DANS LA PILE DES OBJETS POUR QUE
C  L'INTERPRETATION NE SOIT PAS DECALEE.
      IF(NARG.NE.0) THEN
      NN=LMNNOM
      N=NN+NARG +1
      IF(N.GT.INOOB1(/1) ) THEN
         N=N+50
         SEGADJ ITABOB,ITABOC,ITABOD
      ENDIF
         if(nbesc.ne.0) segact ipiloc
         DO 30 I=1,NARG
         LMNNOM=LMNNOM+1
         INOOB1(NN+I)=NOMMM(I)
         IOUEP2(NN+I)=0
         IF(IIMPI.EQ.1754) THEN
            IDEBCH=IPCHAR(NOMMM(I) )
            IFINCH= IPCHAR(NOMMM(I)+1)-1
            NAM = ICHARA( IDEBCH:IFINCH)
*           CALL NOMCHA (NAM,NAM)
            WRITE(IOIMP,6438) NAM,NTYP(I)
 6438       FORMAT('  MAPR : ARGUMENT TYPE  ',A24,2X,A8)
         ENDIF
 30      CONTINUE
*         write(6,*) ' inomp avant aoppel nomobj' , inomp
*  ecriture du nom de la procedur
c          CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
        if (nbesc.ne.0) SEGDES,IPILOC
      ENDIF
      NN=LMNNOM
      N=NN+4
      IF(N.GT.INOOB1(/1) ) THEN
         N=N+50
         SEGADJ ITABOB,ITABOC,ITABOD
      ENDIF
      CALL NOMCHA('#1','#1')
      CALL NOMCHA('#2','#2')
      CALL NOMCHA('#3','#3')
* on ecrit aussi le nom de la procedure  pour pouvoir les quitter!
*      CALL nomobj('PROCEDUR',INOMP,MBLO1)
      IPTEM=0
      CALL NOUTRU
      LIRM(1)=-1
C   ON LIT TOUT JUSQU'AU MOT FINPROCEDURE  ou FINMETHODE
      MTEMP=MBLOC
      nlev=20
      nsi=50
      segini iitra
      ilev=1
  11  CONTINUE
      IF(IERR.NE.0) GO TO 1600
      CALL NOUTRU
      LECTAB=1
      INTEXT=1
      CALL LIRMO3(MCLE,7,IRET,0,LIRM)
*      write(6,fmt='('' lecture repe fin finp'',i6)') iret
      LECTAB=0
      INTEXT=0
*     IF (IRET.EQ.0) GOTO 11
      GOTO (21,22,23,23,24,25,26),IRET
  21  CALL REPETE(1)
      ilev=ilev+1
      if( ilev.gt.nlev) then
        nlev=nlev+20
        segadj iitra
      endif
      if(iimpi.eq.5) then
        write(6,*)'$$$$$$$$$$$$$$$ nouveau bloc de niveau ilev  ' ,ilev
      endif
C  NE LIRE QU'UNE FOIS LA BOUCLE
      MBCONT=1
      GOTO 11
  22  CONTINUE
      CALL QUETYP (  CHAANC,0,IRETI)
      IF(IRETI.EQ.0) GO TO 11
      CALL FIN
      if(iimpi.eq.5) then
      write(6,*)'$$$$$$$$$$$$$$$$ Fermeture du bloc de niveau  ' , ilev
      endif
      if( ilevel(ilev).ne.0) then
        moterr(1:8)= inomp
        call erreur( 1022)
        return
      endif
      ilev=ilev - 1
      GOTO 11
   24 Continue
      ilevel(ilev)=ilevel(ilev)+1
      if(ilevel(ilev).gt.nsi) then
        nsi=nsi+50
        segadj iitra
      endif
      if(iimpi.eq.5) then
      ip=ilevel(ilev)
      write(6,*) '$$$$$$$$$$$$$$$$$$ ouverture d un ',ip, ' ieme SI'
      endif
      go to 11
   25 continue
      if( iimpi.eq.5) then
        ip=ilevel(ilev)
        write(6,*) '$$$$$$$$$$$$$$$ SINON du ',ip, 'ieme SI'
       endif
      if(ilevel(ilev).eq.0) then
        moterr(1:8)= inomp
        call erreur(1020)
        return
      endif
      if( isino(ilev,ilevel(ilev)).ne.0)then
        moterr(1:8)= inomp
        call erreur(1024)
        return
      endif
      isino(ilev,ilevel(ilev))=1
      go to 11
   26 continue
      if(ilevel(ilev).le.0) then
        moterr(1:8)= inomp
        call erreur(1021)
        return
      endif
      if( iimpi.eq.5) then
        ip=ilevel(ilev)
        write(6,*) '$$$$$$$$$$$$$$$$    Fermeture du ',ip,' ieme SI'
      endif
      isino(ilev,ilevel(ilev))=0
      ilevel(ilev)=ilevel(ilev) - 1
      go to 11
C
C  ON VIENT DE LIRE FINPROC
C  IL FAUT LIRE LES RESULTATS POUR STOCKER LEURS PLACES DANS LA PILE
C  OBJET
C
  23  CONTINUE
      if( ilev.ne.1. or . ilevel.(ilev).ne.0) then
        moterr(1:8)= inomp
        call erreur (1023)
        return
      endif
      segsup iitra
*        write(6,fmt='('' lecture finpro'')')
      IF (MBLOC.NE.MTEMP) THEN
C
C     ON A OUBLIE DE FERMER UN BLOC
C
        MBLOC =MTEMP
        SEGACT,MBLO1
        MOTERR=MBLO1.NCONBO
        SEGDES,MBLO1
        CALL ERREUR(154)
        SEGACT MBLOC*MOD
        MTEM  =MBLSUP
        MTXBLC=MTXBL
        SEGDES MTXBLC
        ISSPOT=ISPOTE
        SEGDES ISSPOT
        SEGDES MBLOC
        MBLOC=MTEM
        SEGACT MBLOC*MOD
        ISSPOT=ISPOTE
        SEGACT ISSPOT*MOD
        MTXBLC=MTXBL
        IF(MTXBL.NE.0) SEGACT MTXBLC
        CALL NOMOBJ('ANNULE',INOMP,MBLOC)
        RETURN
      ENDIF
      IPTEM=0
      CALL NOUTRU
      SEGINI IARGUM
      MARGUM=IARGUM
      MTXMET=IRZTC
*      write(6,*) ' mappr  mtxmet ', irztc
      IF(IIMPI.EQ.1754) WRITE(6,5911) IARGUM,NARG
 5911 FORMAT('  MAPR  : IARGUM NARG   ',3I5)
      IF(NARG.NE.0) THEN
        DO 43 I=1,NARG
        ILTYPA(I)=ILSSTY(I)
        IOBLIG(I)=IOBLI(I)
  43    CONTINUE
        DO 41 I=1,NARG
        MTYARG(I)=NTYP(I)
        MSTYPA(I)=NSSTYP(I)
  41    CONTINUE
      ENDIF
      SEGSUP ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
C      MRESU=MBLOC
C
C  ON FERME LE BLOC REPETE on ajuste mtxblc
C
      MFIOBJ=LMNNOM
      JDEOBJ=MDEOBJ
      msapii=mdeobj
      MTEM=MBLSUP
      MTXBLC=MTXBL
      NINST=NINSTV+1
      IPVINN=MTXBA(NINST)
      NBNOMM=LMTXBM(NINST)
      IF(IIMPI.EQ.1756) WRITE(IOIMP,1788)NINST,IPVINN,NBNOMM
 1788 FORMAT(' apres ajustement NINST IPVINN NBNOMM',3I8)
      SEGADJ MTXBLC
      SEGDES MTXBLC
      ISSPOT=ISPOTE
      SEGDES ISSPOT
      SEGDES MBLOC
      MBLOC=MTEM
      SEGACT MBLOC*MOD
      ISSPOT=ISPOTE
      SEGACT ISSPOT*MOD
      MTXBLC=MTXBL
      IF(MTXBL.NE.0) SEGACT MTXBLC

C
C  ON SAUVE LA VALEUR DES FLOTTANTS
C
      NREE = 0
      DO 33 I=JDEOBJ,LMNNOM
      IF(INOOB2(I).EQ.'FLOTTANT') NREE = NREE + 1
   33 CONTINUE
      MTXFLO=0
      IF(NREE.NE.0) THEN
        SEGINI MTXFL3
        MTXFLO=MTXFL3
        NREE=0
        if(nbesc.ne.0) segact ipiloc
        DO 34 I=JDEOBJ,LMNNOM
        IF(INOOB2(I).EQ.'FLOTTANT') THEN
            NREE = NREE + 1
            XTFLO(NREE)= XIFLOT(IOUEP2(I))
            MITFLO(NREE)=I-jdeobj+1
        ENDIF
   34   CONTINUE
        if(nbesc.ne.0) SEGDES,IPILOC
        SEGDES MTXFL3
      ENDIF
C
C
C  ** EFFACEMENT DES NOMS D'OBJET DANS LA TABLE
C
      NIIS=LMNNOM-JDEOBJ+1
      NIS = NIIS
      SEGINI MTXBI3
      MTXBB=MTXBI3
      SEGDES IARGUM
      if(nbesc.ne.0) segact ipiloc
      DO 32 I=JDEOBJ,LMNNOM
      MTXBI(I-JDEOBJ+1)=INOOB1(I)
      mtxbd(i-JDEOBJ+1)=inoob2(i)
      mtxbe(i-JDEOBJ+1)=iouep2(i)
C       IPP= INOOB1(I)
      IDEBCH=IPCHAR(INOOB1(I))
*tc      IF(ICHARA(IDEBCH:IDEBCH).EQ.'&'.AND.INOOB2(I).EQ.'ENTIER  ')
*tc     1  INOOB2(I)=' '
      INOOB1(I)=0
      inoob2(i)=' '
      iouep2(i)=-10000
   32 CONTINUE
      if(nbesc.ne.0) SEGDES,IPILOC
      SEGDES MTXBI3
      SEGDES IARGUM
      lmnnom=lmnpre

      RETURN
C
C ERREUR DETECTE APRES INITIALISATION DU BLOC,ON FERME TOUS LES BLOCS
C JUSQU'A CELUI DE LA PROCEDURE
 1600 CONTINUE
      IDER = MARGUM
      MTEM=MBLSUP
      MTXBLC=MTXBL
      SEGDES MTXBLC
      ISSPOT=ISPOTE
      SEGDES ISSPOT
      SEGDES MBLOC
      MBLOC=MTEM
      SEGACT MBLOC*MOD
      ISSPOT=ISPOTE
      SEGACT ISSPOT*MOD
      MTXBLC=MTXBL
      IF(MTXBL.NE.0) SEGACT MTXBLC
      IF(IDER.EQ.0) GO TO 1500
      IARGUM=IDER
      SEGDES IARGUM
      lmnnom=lmnpre
 1500 CONTINUE
C
C  ON A  TROUVE UNE ERREUR  AVANT D'OUVRIR LE BLOC
C
      CALL NOMOBJ('ANNULE',INOMP,MBLO1)
      END