Télécharger la plaquette Cast3M


fr en

Télécharger mapr.eso

Retour à la liste

Numérotation des lignes : 

mapr

  1. C MAPR      SOURCE    CB215821  24/07/17    21:15:09     11961          
  2.       SUBROUTINE MAPR  (IRZTC)
  3.       IMPLICIT INTEGER(I-N)
  4. -INC PPARAM
  5. -INC CCOPTIO
  6. -INC SMBLOC
  7. -INC CCNOYAU
  8. -INC CCASSIS
  9.       SEGMENT  ISEGP1
  10.            INTEGER NOMMM(NIS)
  11.       ENDSEGMENT
  12.       SEGMENT  ISEGP2
  13.            CHARACTER*(8) NTYP(NIS)
  14.       ENDSEGMENT
  15.       SEGMENT  ISEGP3
  16.            INTEGER IOBLI(NIS)
  17.       ENDSEGMENT
  18.       SEGMENT  ISEGP4
  19.            CHARACTER*(8) NSSTYP(NIS)
  20.       ENDSEGMENT
  21.       SEGMENT  ISEGP5
  22.            INTEGER ILSSTY(NIS)
  23.       ENDSEGMENT
  24.       SEGMENT ISEG3
  25.            INTEGER IRESAR(NIS)
  26.       ENDSEGMENT
  27.       SEGMENT IITRA
  28.         integer ilevel(nlev),isino(nlev,nsi)
  29.       ENDSEGMENT
  30.       CHARACTER*(8) ICHA,CHAANC
  31.       CHARACTER*(LONOM) CNOM,INOMP,NAM
  32.       LOGICAL LOGI
  33.       REAL*8 XRET
  34.       DIMENSION LIRM(7)
  35.       CHARACTER*4 MCLE(7), MAST(2)
  36.       DATA  MCLE/'REPE','FIN ','FINP','FINM','SI','SINO','FINS'/
  37.       DATA MAST/'*   ','/   '/
  38. C  LECTURE DU NOM DE LA PROCEDURE
  39.       if(iimpi.eq.1756)write(6,*)'avant appel quetyp lmnnno ',lmnnom
  40. *      if(iimpi.eq.1876) write(6,*) ' mapr appel quetyp'
  41.       CALL QUETYP (CHAANC ,0,IRETOU)
  42.       if(iimpi.eq.1756) write(6,*)'mapr  retour quetyp',chaanc ,lmnnom
  43.       IF(IRETOU.EQ.0) RETURN
  44.       IF(IERR.NE.0) RETURN
  45.         IF(CHAANC.EQ.'ENTIER  ') THEN
  46.                 CALL LIRENT ( II,1,IRETOU)
  47.         ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
  48.                 CALL LIRREE(XRET,1,IRETOU)
  49.         ELSEIF(CHAANC.EQ.'MOT     ') THEN
  50. *      if(iimpi.eq.1876) write(6,*) ' mapr appel lircha'
  51.                 CALL LIRCHA(ICHA,1,IRETOU)
  52.         ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
  53.                 CALL LIRLOG(LOGI,1,IRETOU)
  54.         ELSE
  55.                 CALL LIROBJ(CHAANC,IRET,1,IRETOU)
  56.         ENDIF
  57.       CALL QUENOM ( CNOM)
  58.        if(iimpi.eq.1756) write(6,*) ' mapr nom de la procedur' , CNOM
  59.       IF(CNOM.EQ.' ') THEN
  60.          CALL ERREUR(21  )
  61.          RETURN
  62.       ENDIF
  63.       IF(IERR.NE.0) RETURN
  64.       SEGINI MBLO1
  65.          NVQTEM=20
  66.          SEGINI ISSPOT
  67.          MBLO1.ISPOTE=ISSPOT
  68.          INOMP=CNOM
  69. *         write(6,*) ' lmnnom avant nomobj'  , lmnnom
  70.       CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
  71. *          write(6,*) ' lmnnom apres nomobj'  , lmnnom
  72.       moterr(1:8)=inomp
  73.       IF(IIMPI.EQ.1754)WRITE(IOIMP,101) INOMP
  74.  101  FORMAT(' DANS MAPR  NOM DE LA PROCEDURE  ' ,A24)
  75. C      IARG=0
  76.       MBLO1.MARGUM=0
  77.       NIS=0
  78.       SEGINI ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  79. C LECTURE DES ARGUMENTS ET DE LEURS TYPE ON LES METS DANS NOMMM ET NTYP
  80. *  ESSAI PV ON VERROUILLE LES TEXTES PENDANT LA LECTURE DES ARGUMENTS
  82.    1  CONTINUE
  83.       ICHA=' '
  84.       CALL QUETYP (CHAANC ,0,IRETOU)
  85. *     WRITE(6,FMT='('' CHAANC APRES QUETYP '',A8)') CHAANC
  86.       IF(IRETOU.EQ.0) GOTO  2
  87.       IF(IERR.NE.0) RETURN
  88.         IF(CHAANC.EQ.'ENTIER  ') THEN
  89.                 CALL LIRENT ( II,1,IRETOU)
  90.         ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
  91.                 CALL LIRREE(XRET,1,IRETOU)
  92.         ELSEIF(CHAANC.EQ.'MOT     ') THEN
  93.                 CALL LIRCHA(ICHA,1,IRETOU)
  94.         ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
  95.                 CALL LIRLOG(LOGI,1,IRETOU)
  96.         ELSE
  97.                 CALL LIROBJ(CHAANC,IRET,1,IRETOU)
  98.         ENDIF
  99. *     WRITE(6,FMT='('' CHAANC AVANT QUENON '',A8)') CHAANC
  100.       CALL QUENOM ( CNOM)
  101.       DO 765 ILW=LONOM,1,-1
  102.       IF(CNOM(ILW:ILW).NE.' ') GO TO 764
  103.   765 CONTINUE
  104.   764 LE=ILW
  105.       CALL POSCHA(CNOM(1:LE),IPOSCH)
  106.    2  CONTINUE
  107.       IF(IRETOU.NE.0) THEN
  108.         NIS=NOMMM(/1)+1
  109.         SEGADJ ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  110.         NOMMM(NIS)=IPOSCH
  111.         CALL LIRMOT(MAST,2,IAST,0)
  112.           IF(IAST.NE.0) THEN
  113.             CALL LIRCHA(ICHA,1,IRETOU)
  114.             IF(IERR.NE.0) GO TO 1500
  115.             NTYP(NIS)=ICHA
  116.             NSSTYP(NIS)=' '
  117.             ILSSTY(NIS)=0
  118.             IF(IAST.EQ.1) THEN
  119.                IOBLI(NIS)=1
  120.             ELSE
  121.                IOBLI(NIS)=0
  122.             ENDIF
  123. *      WRITE(6,FMT='('' ICHA TYPE DE L ARGUMENT '',A8)') ICHA
  124.             IF(ICHA.EQ.'TABLE   ') THEN
  125.                CHAANC=' '
  126.                CALL QUETYP(CHAANC,0,IRETOU)
  127.                IF(CHAANC.NE.'MOT     ') GO TO 1
  128.                CALL LIRMOT(MAST,1,IAST,0)
  129.                IF(IAST.EQ.0) GO TO 1
  130.                ICHA=' '
  131.                CALL LIRCHA(ICHA,1,IRETOU)
  132. *      WRITE(6,FMT='('' ICHA TYPE DE LA TABLE   '',A8)') ICHA
  133.                IF(IERR.NE.0) GO TO 1500
  134.                NSSTYP(NIS)=ICHA
  135.                ILSSTY(NIS)=IRETOU
  136.             ENDIF
  137.          ELSE
  138.             NTYP(NIS)=' '
  139.             NSSTYP=' '
  140.             IOBLI(NIS)=1
  141.             ILSSTY(NIS)=0
  142.          ENDIF
  143.          GO TO 1
  144.       ENDIF
  145.       NARG=NOMMM(/1)
  146. *  FIN VERROUILLAGE TEXTES
  148. C  CREATION D'UN BLOC REPETE
  149.       MTEM=MBLOC
  150.       IF(MTXBL.NE.0)  THEN
  151.          MTXBLC=MTXBL
  152.          SEGDES MTXBLC
  153.       ENDIF
  154.       ISSPOT=ISPOTE
  155.       SEGDES ISSPOT
  156.       SEGDES MBLOC
  157.       MBLOC=MBLO1
  158.       MBLSUP=MTEM
  159.       lmnpre=lmnnom
  160. **     write(6,*) ' entree dans mapr mblsup mbloc:',mblsup,mbloc
  161.       MDEOBJ=LMNNOM+1
  162.       NBNOMM=1200
  163.       NINST=1200
  164.       IPVINN=3000
  165.       SEGINI MTXBLC
  166.       MTXBL=MTXBLC
  167.       MBLPRO=0
  168.       MBFONC=1
  169.       MBCOUR=0
  170.       MBCONT=1
  171. C  ECRITURE DES ARGUMENTS DANS LA PILE DES OBJETS POUR QUE
  172. C  L'INTERPRETATION NE SOIT PAS DECALEE.
  173.       IF(NARG.NE.0) THEN
  174.       NN=LMNNOM
  175.       N=NN+NARG +1
  176.       IF(N.GT.INOOB1(/1) ) THEN
  177.          N=N+50
  178.          SEGADJ ITABOB,ITABOC,ITABOD
  179.       ENDIF
  180.          if(nbesc.ne.0) segact ipiloc
  181.          DO 30 I=1,NARG
  182.          LMNNOM=LMNNOM+1
  183.          INOOB1(NN+I)=NOMMM(I)
  184.          IOUEP2(NN+I)=0
  185.          IF(IIMPI.EQ.1754) THEN
  186.             IDEBCH=IPCHAR(NOMMM(I) )
  187.             IFINCH= IPCHAR(NOMMM(I)+1)-1
  188.             NAM = ICHARA( IDEBCH:IFINCH)
  189. *           CALL NOMCHA (NAM,NAM)
  190.             WRITE(IOIMP,6438) NAM,NTYP(I)
  191.  6438       FORMAT('  MAPR : ARGUMENT TYPE  ',A24,2X,A8)
  192.          ENDIF
  193.  30      CONTINUE
  194. *         write(6,*) ' inomp avant aoppel nomobj' , inomp
  195. *  ecriture du nom de la procedur
  196. c          CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
  197.         if (nbesc.ne.0) SEGDES,IPILOC
  198.       ENDIF
  199.       NN=LMNNOM
  200.       N=NN+4
  201.       IF(N.GT.INOOB1(/1) ) THEN
  202.          N=N+50
  203.          SEGADJ ITABOB,ITABOC,ITABOD
  204.       ENDIF
  205.       CALL NOMCHA('#1','#1')
  206.       CALL NOMCHA('#2','#2')
  207.       CALL NOMCHA('#3','#3')
  208. * on ecrit aussi le nom de la procedure  pour pouvoir les quitter!
  209. *      CALL nomobj('PROCEDUR',INOMP,MBLO1)
  210.       IPTEM=0
  211.       CALL NOUTRU
  212.       LIRM(1)=-1
  213. C   ON LIT TOUT JUSQU'AU MOT FINPROCEDURE  ou FINMETHODE
  214.       MTEMP=MBLOC
  215.       nlev=20
  216.       nsi=50
  217.       segini iitra
  218.       ilev=1
  219.   11  CONTINUE
  220.       IF(IERR.NE.0) GO TO 1600
  221.       CALL NOUTRU
  222.       LECTAB=1
  224.       CALL LIRMO3(MCLE,7,IRET,0,LIRM)
  225. *      write(6,fmt='('' lecture repe fin finp'',i6)') iret
  226.       LECTAB=0
  228. *     IF (IRET.EQ.0) GOTO 11
  229.       GOTO (21,22,23,23,24,25,26),IRET
  230.   21  CALL REPETE(1)
  231.       ilev=ilev+1
  232.       if( ilev.gt.nlev) then
  233.         nlev=nlev+20
  234.         segadj iitra
  235.       endif
  236.       if(iimpi.eq.5) then
  237.         write(6,*)'$$$$$$$$$$$$$$$ nouveau bloc de niveau ilev  ' ,ilev
  238.       endif
  239. C  NE LIRE QU'UNE FOIS LA BOUCLE
  240.       MBCONT=1
  241.       GOTO 11
  242.   22  CONTINUE
  243.       CALL QUETYP (  CHAANC,0,IRETI)
  244.       IF(IRETI.EQ.0) GO TO 11
  245.       CALL FIN
  246.       if(iimpi.eq.5) then
  247.       write(6,*)'$$$$$$$$$$$$$$$$ Fermeture du bloc de niveau  ' , ilev
  248.       endif
  249.       if( ilevel(ilev).ne.0) then
  250.         moterr(1:8)= inomp
  251.         call erreur( 1022)
  252.         return
  253.       endif
  254.       ilev=ilev - 1
  255.       GOTO 11
  256.    24 Continue
  257.       ilevel(ilev)=ilevel(ilev)+1
  258.       if(ilevel(ilev).gt.nsi) then
  259.         nsi=nsi+50
  260.         segadj iitra
  261.       endif
  262.       if(iimpi.eq.5) then
  263.       ip=ilevel(ilev)
  264.       write(6,*) '$$$$$$$$$$$$$$$$$$ ouverture d un ',ip, ' ieme SI'
  265.       endif
  266.       go to 11
  267.    25 continue
  268.       if( iimpi.eq.5) then
  269.         ip=ilevel(ilev)
  270.         write(6,*) '$$$$$$$$$$$$$$$ SINON du ',ip, 'ieme SI'
  271.        endif
  272.       if(ilevel(ilev).eq.0) then
  273.         moterr(1:8)= inomp
  274.         call erreur(1020)
  275.         return
  276.       endif
  277.       if( isino(ilev,ilevel(ilev)).ne.0)then
  278.         moterr(1:8)= inomp
  279.         call erreur(1024)
  280.         return
  281.       endif
  282.       isino(ilev,ilevel(ilev))=1
  283.       go to 11
  284.    26 continue
  285.       if(ilevel(ilev).le.0) then
  286.         moterr(1:8)= inomp
  287.         call erreur(1021)
  288.         return
  289.       endif
  290.       if( iimpi.eq.5) then
  291.         ip=ilevel(ilev)
  292.         write(6,*) '$$$$$$$$$$$$$$$$    Fermeture du ',ip,' ieme SI'
  293.       endif
  294.       isino(ilev,ilevel(ilev))=0
  295.       ilevel(ilev)=ilevel(ilev) - 1
  296.       go to 11
  297. C
  298. C  ON VIENT DE LIRE FINPROC
  299. C  IL FAUT LIRE LES RESULTATS POUR STOCKER LEURS PLACES DANS LA PILE
  300. C  OBJET
  301. C
  302.   23  CONTINUE
  303.       if( ilev.ne.1. or . ilevel.(ilev).ne.0) then
  304.         moterr(1:8)= inomp
  305.         call erreur (1023)
  306.         return
  307.       endif
  308.       segsup iitra
  309. *        write(6,fmt='('' lecture finpro'')')
  310.       IF (MBLOC.NE.MTEMP) THEN
  311. C
  312. C     ON A OUBLIE DE FERMER UN BLOC
  313. C
  314.         MBLOC =MTEMP
  315.         SEGACT,MBLO1
  316.         MOTERR=MBLO1.NCONBO
  317.         SEGDES,MBLO1
  318.         CALL ERREUR(154)
  319.         SEGACT MBLOC*MOD
  320.         MTEM  =MBLSUP
  321.         MTXBLC=MTXBL
  322.         SEGDES MTXBLC
  323.         ISSPOT=ISPOTE
  324.         SEGDES ISSPOT
  325.         SEGDES MBLOC
  326.         MBLOC=MTEM
  327.         SEGACT MBLOC*MOD
  328.         ISSPOT=ISPOTE
  329.         SEGACT ISSPOT*MOD
  330.         MTXBLC=MTXBL
  331.         IF(MTXBL.NE.0) SEGACT MTXBLC
  332.         CALL NOMOBJ('ANNULE',INOMP,MBLOC)
  333.         RETURN
  334.       ENDIF
  335.       IPTEM=0
  336.       CALL NOUTRU
  337.       SEGINI IARGUM
  338.       MARGUM=IARGUM
  339.       MTXMET=IRZTC
  340. *      write(6,*) ' mappr  mtxmet ', irztc
  341.       IF(IIMPI.EQ.1754) WRITE(6,5911) IARGUM,NARG
  342.  5911 FORMAT('  MAPR  : IARGUM NARG   ',3I5)
  343.       IF(NARG.NE.0) THEN
  344.         DO 43 I=1,NARG
  345.         ILTYPA(I)=ILSSTY(I)
  346.         IOBLIG(I)=IOBLI(I)
  347.   43    CONTINUE
  348.         DO 41 I=1,NARG
  349.         MTYARG(I)=NTYP(I)
  350.         MSTYPA(I)=NSSTYP(I)
  351.   41    CONTINUE
  352.       ENDIF
  353.       SEGSUP ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  354. C      MRESU=MBLOC
  355. C
  356. C  ON FERME LE BLOC REPETE on ajuste mtxblc
  357. C
  358.       MFIOBJ=LMNNOM
  359.       JDEOBJ=MDEOBJ
  360.       msapii=mdeobj
  361.       MTEM=MBLSUP
  362.       MTXBLC=MTXBL
  363.       NINST=NINSTV+1
  364.       IPVINN=MTXBA(NINST)
  365.       NBNOMM=LMTXBM(NINST)
  366.       IF(IIMPI.EQ.1756) WRITE(IOIMP,1788)NINST,IPVINN,NBNOMM
  367.  1788 FORMAT(' apres ajustement NINST IPVINN NBNOMM',3I8)
  368.       SEGADJ MTXBLC
  369.       SEGDES MTXBLC
  370.       ISSPOT=ISPOTE
  371.       SEGDES ISSPOT
  372.       SEGDES MBLOC
  373.       MBLOC=MTEM
  374.       SEGACT MBLOC*MOD
  375.       ISSPOT=ISPOTE
  376.       SEGACT ISSPOT*MOD
  377.       MTXBLC=MTXBL
  378.       IF(MTXBL.NE.0) SEGACT MTXBLC
  379.  
  380. C
  381. C  ON SAUVE LA VALEUR DES FLOTTANTS
  382. C
  383.       NREE = 0
  384.       DO 33 I=JDEOBJ,LMNNOM
  385.       IF(INOOB2(I).EQ.'FLOTTANT') NREE = NREE + 1
  386.    33 CONTINUE
  387.       MTXFLO=0
  388.       IF(NREE.NE.0) THEN
  389.         SEGINI MTXFL3
  390.         MTXFLO=MTXFL3
  391.         NREE=0
  392.         if(nbesc.ne.0) segact ipiloc
  393.         DO 34 I=JDEOBJ,LMNNOM
  394.         IF(INOOB2(I).EQ.'FLOTTANT') THEN
  395.             NREE = NREE + 1
  396.             XTFLO(NREE)= XIFLOT(IOUEP2(I))
  397.             MITFLO(NREE)=I-jdeobj+1
  398.         ENDIF
  399.    34   CONTINUE
  400.         if(nbesc.ne.0) SEGDES,IPILOC
  401.         SEGDES MTXFL3
  402.       ENDIF
  403. C
  404. C
  405. C  ** EFFACEMENT DES NOMS D'OBJET DANS LA TABLE
  406. C
  407.       NIIS=LMNNOM-JDEOBJ+1
  408.       NIS = NIIS
  409.       SEGINI MTXBI3
  410.       MTXBB=MTXBI3
  411.       SEGDES IARGUM
  412.       if(nbesc.ne.0) segact ipiloc
  413.       DO 32 I=JDEOBJ,LMNNOM
  414.       MTXBI(I-JDEOBJ+1)=INOOB1(I)
  415.       mtxbd(i-JDEOBJ+1)=inoob2(i)
  416.       mtxbe(i-JDEOBJ+1)=iouep2(i)
  417. C       IPP= INOOB1(I)
  418.       IDEBCH=IPCHAR(INOOB1(I))
  419. *tc      IF(ICHARA(IDEBCH:IDEBCH).EQ.'&'.AND.INOOB2(I).EQ.'ENTIER  ')
  420. *tc     1  INOOB2(I)=' '
  421.       INOOB1(I)=0
  422.       inoob2(i)=' '
  423.       iouep2(i)=-10000
  424.    32 CONTINUE
  425.       if(nbesc.ne.0) SEGDES,IPILOC
  426.       SEGDES MTXBI3
  427.       SEGDES IARGUM
  428.       lmnnom=lmnpre
  429.  
  430.       RETURN
  431. C
  432. C ERREUR DETECTE APRES INITIALISATION DU BLOC,ON FERME TOUS LES BLOCS
  433. C JUSQU'A CELUI DE LA PROCEDURE
  434.  1600 CONTINUE
  435.       IDER = MARGUM
  436.       MTEM=MBLSUP
  437.       MTXBLC=MTXBL
  438.       SEGDES MTXBLC
  439.       ISSPOT=ISPOTE
  440.       SEGDES ISSPOT
  441.       SEGDES MBLOC
  442.       MBLOC=MTEM
  443.       SEGACT MBLOC*MOD
  444.       ISSPOT=ISPOTE
  445.       SEGACT ISSPOT*MOD
  446.       MTXBLC=MTXBL
  447.       IF(MTXBL.NE.0) SEGACT MTXBLC
  448.       IF(IDER.EQ.0) GO TO 1500
  449.       IARGUM=IDER
  450.       SEGDES IARGUM
  451.       lmnnom=lmnpre
  452.  1500 CONTINUE
  453. C
  454. C  ON A  TROUVE UNE ERREUR  AVANT D'OUVRIR LE BLOC
  455. C
  456.       CALL NOMOBJ('ANNULE',INOMP,MBLO1)
  457.       END
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  
  466.  

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