1 : C REPETE SOURCE CHAT 12/03/28 21:15:07 7340 2 : C CET OPERATEUR INITIALISE LA FONCTION REPETER DE GIBIANE 3 : C IL DOIT ETRE SUIVI DU NOM D'UN BLOC REPETER 4 : C SI CE BLOC EXISTE LIRNOM EST DEROUTE POUR LE LIRE 5 : C SI CE BLOC N'EXISTE PAS IL LE CREE ET LIRNOM LE REMPLIT 6 : C A LA PREMIERE INTERPRETATION 7 : C LE BLOC FINI PAR FIN "BLOC" 8 : C 9 : SUBROUTINE REPETE 10 : IMPLICIT INTEGER(I-N) 11 : -INC SMBLOC 12 : -INC CCNOYAU 13 : -INC CCOPTIO 14 : CHARACTER*(8) ICHA,INOM,ITCH,ICHC 15 : CHARACTER*(9) ICHB 16 : MBC=0 16 : CALL LIROBJ('BLOC ',MBLO1,0,IREBLO) 17 : if( ireblo.ne.0) imablu=jpoob2(imotlu) 18 : IF(IREBLO.EQ.0) THEN 18 : CALL QUETYP(ICHA,1,IRETOU) 19 : IF(IERR.NE.0) RETURN 20 : IF(ICHA.EQ.'MOT ') THEN 20 : CALL LIRCHA(ICHB,1,IRETOU) 21 : IF(ICHB(9:9).NE.' ') THEN 21 : CALL ERREUR (315) 22 : RETURN 23 : ENDIF 24 : ICHA=ICHB 25 : ELSE 25 : CALL LIROBJ(ICHA,IRE,1,IRETOU) 25 : CALL QUENOM ( ICHA) 26 : IF(ICHA(1:1).EQ.' ') THEN 26 : CALL ERREUR(315) 27 : RETURN 28 : ENDIF 29 : ENDIF 30 : ENDIF 30 : CALL LIRENT(MBC,0,IRETOU) 31 : IF (IERR.NE.0) RETURN 32 : * TEST QUE L'INSTRUCTION EST EPUISEE - PROBLEME AVEC LA PRECOMPILATION 32 : * CALL QUETYP(ITCH,0,IRETO) 33 : * IF (IRETO.EQ.0) GOTO 20 34 : * MOTERR(1:8)=ITCH 34 : * CALL LIRABJ(ITCH,IRET,1,IRETO) 34 : * CALL QUENOM(ITCH) 35 : * MOTERR(9:16)=ITCH 35 : * CALL ERREUR(551) 36 : * RETURN 37 : 20 CONTINUE 38 : MDEOBT=MDEOBJ 39 : MFIOBT=MFIOBJ 40 : MBLPRT=MBLPRO 41 : MTXBLC=MTXBL 42 : MARM = MARGUM 43 : IF (MBLSUP.NE.0) SEGDES MTXBLC 44 : ISSPOT=ISPOTE 45 : SEGDES ISSPOT 46 : IRETCO=MOBJCO 47 : SEGDES MBLOC 48 : MTEMP=MBLOC 49 : IF (IREBLO.EQ.0) GOTO 10 50 : C 51 : C LE BLOC REPETER EXISTE DEJA 52 : C 53 : segini,mbloc=MBLO1 54 : iouep2(imablu)=mbloc 55 : SEGACT MBLOC*MOD 56 : ISSPOT=ISPOTE 57 : SEGACT ISSPOT*MOD 58 : * write(6,*) 'ispote ipotem(1) ', ispote, ipotem(1) 59 : MOBJCO=IRETCO 60 : mdecip = mdeobt - mdeobj 61 : do iou=1,ipotem(/1) 62 : ipotem(iou)=ipotem(iou)+mdecip 63 : enddo 64 : MDEOBJ=MDEOBT 65 : MFIOBJ=MFIOBT 66 : MBLPRO=MBLPRT 67 : MBLSUP=MTEMP 68 : MARGUM = MARM 69 : MTXBLC=MTXBL 70 : SEGACT MTXBLC 71 : * ILON= MTXBLC(/1) 72 : MBCOUR=0 73 : MBCONT=MBC 74 : MBFONC=0 75 : MBERR =0 76 : ICHC=NCONBO 77 : ICONBO=1 78 : IIPROU=ICONBO 79 : * write(6,*)' bloc2 repete mbloc mdeobj lmnnom',mbloc,mdeobj,lmnnom 79 : CALL NOMENT(ICHC,IIPROU) 80 : RETURN 81 : 10 CONTINUE 82 : C 83 : C ON EST EN DEFINITION D'UN NOUVEAU BLOC 84 : C 85 : NBMOT=0 86 : SEGINI MBLOC 87 : NVQTEM=20 88 : SEGINI ISSPOT 89 : ISPOTE= ISSPOT 90 : NBNOMM=1200 91 : NINST=1200 92 : IPVINN=3000 93 : SEGINI MTXBLC 94 : NINSTV=0 95 : IPVINV=0 96 : MTXBL=MTXBLC 97 : MBLSUP=MTEMP 98 : MARGUM = MARM 99 : MBCONT=MBC 100 : MBLPRO=0 101 : MBCOUR=0 102 : MBFONC=1 103 : MBERR=0 104 : MDEOBJ=MDEOBT 105 : MFIOBJ=MFIOBT 106 : MOBJCO=IRETCO 107 : * write(6,*) 'creation de bloc mblo mde lmnn',mbloc,mdeobj,lmnnom 107 : CALL NOMOBJ('BLOC ',ICHA,MBLOC) 107 : call savseg (mbloc) 107 : call savseg (ISSPOT) 107 : call savseg(MTXBLC) 108 : ICHC(1:1)='&' 109 : ICHC(2:8)=ICHA(1:7) 110 : NCONBO=ICHC 111 : ICONBO=1 112 : IIPROU=ICONBO 112 : CALL NOMENT(ICHC,IIPROU) 113 : RETURN 114 : END 115 : 116 : 117 :
© Cast3M 2003 - All rights reserved.
Disclaimer