Sources Esope | Cast3M

trbac
C TRBAC     SOURCE    PV090527  24/11/15    21:15:09     12080          
      SUBROUTINE TRBAC
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMBLOC
-INC CCNOYAU
 
      SEGMENT MTTE
         CHARACTER*(LOCHAI) PHRA
         CHARACTER*72       TRA
         CHARACTER*(LONOM)  NOM
         INTEGER INDI
      ENDSEGMENT
 
      POINTEUR MTT1.MTTE
         CHARACTER*8 FORM
      SEGINI MTTE
 
      CALL TRBAC1(MTTE)
 
      MBCOAN= MBCOUR
    1 CONTINUE
      IXE=0
      IYE=0
      IF(MBLSUP.NE.0) THEN
      DO 105 I=1,INDI
      IF ( PHRA (I:I).NE.'#') GO TO 105
      DO 106 K=I+1,INDI
      IF(PHRA(K:K).EQ. ' ') GO TO 107
      J=K
 106  CONTINUE
 107  J1=J-I
      TRA=' '
      TRA(1:2)='(I'
      WRITE(TRA(3:5),FMT='(I3)')J1
      TRA(6:6)=')'
      READ(PHRA(I+1:J),FMT=TRA,err=105) IYA
      IF(IYA.LT.IYE) GO TO 105
      IXE=I
      IXF=J
      IYE=IYA
  105 CONTINUE
      IF(IXE.NE.0) THEN
         SEGINI MTT1
         MTXBLC=MTXBL
         if(mbcour.eq.0) mbcour = ninstv
         MBCOUR=MBCOUR-1
         NBNOMM=LMTXBM(MBCOUR+1)- LMTXBM(MBCOUR)
         IPVINT=MTXBA(MBCOUR+1)-MTXBA(MBCOUR)
          IDEF= LMTXBM(MBCOUR)
         DO 103 I=1,NBNOMM
          if( mtxblb(i+idef). ge . 0) then
             ITANO1(I)=MTXBLB(I+IDEF) +mdeobj -1
          else
            ITANO1(I)=MTXBLB(I+IDEF)/(-100)
          endif
          ITANOM(I)=MTXBLM(I+IDEF)
C         ITANO1(I)=MTXBLB(I)
C         ITANOM(I)=MTXBLM(I)
  103    CONTINUE
         IDEF=MTXBA(MBCOUR)
         DO 104 I=1,IPVINT
         if( mtxbla(i+idef).gt.0) then
            ITINTE(I)=MTXBLA(I+IDEF) +mdeobj -1
         elseif(mtxbla(i+idef).lt.-99) then
            ITINTE(I)=MTXBLA(I+IDEF)/(-100)
         else
           ITINTE(I)=MTXBLA(I+IDEF)
         endif
C         ITINTE(I)=MTXBLA(I)
  104    CONTINUE
C         SEGDES MTXBLL
         CALL TRBAC1(MTT1)
         PHRA(IXE:IXE)='('
         ILO = INDI-IXF
         IDD= IXE + MTT1.INDI+1
         IF(ILO.NE.0) THEN
            DO 108 K=ILO,1,-1
            PHRA(IDD+K:IDD+K)=PHRA(IXF+K:IXF+K)
  108       CONTINUE
         ENDIF
         IND1=MTT1.INDI
         PHRA(IXE+1:IDD-1)= MTT1.PHRA(1:IND1)
         PHRA(IDD:IDD)=')'
         INDI=IDD+ILO+1
         SEGSUP MTT1
         GO TO 1
      ENDIF
      ENDIF
      MBCOUR=MBCOAN
      FORM ='(1X,A'
      IIA = MAX(1,MIN(INDI,72))
      WRITE(FORM(6:7),FMT='(I2)')IIA
      FORM(8:8)=')'
      WRITE(IOIMP,FMT=FORM) PHRA(1:INDI)
      SEGSUP MTTE
      RETURN
      END