C =================================================================== SubRoutine Debut (ProgNam) C =================================================================== character 1 ProgNam*(*), ! Nom du programme 1 cDate*8,cTime*10 ! Date et heure C =================================================================== open ( 1 File = 'Mouchard.log', 1 Unit = 10, 1 Status = 'unknown', 1 Access = 'append' ) C call Date (cDate) C call Time (cTime) call Date_and_time(cDate,cTime) NCar = len( ProgNam ) DO WHILE ( ProgNam(NCar:NCar).eq.' ' .and. NCar.gt.1 ) NCar = NCar - 1 ENDDO call WC (' ') call WC ('=================================================') call WC 1 (' Debut de '//ProgNam(1:NCar)//' le '//cDate//' a '//cTime) call WC ('=================================================') call WC (' ') C =================================================================== RETURN end C =================================================================== SubRoutine LaFin (ProgNam) C =================================================================== character 1 ProgNam*(*), ! Nom du programme 1 cDate*8,cTime*10 ! Date et heure C =================================================================== C call Date (cDate) C call Time (cTime) call Date_and_time(cDate,cTime) NCar = len( ProgNam ) DO WHILE ( ProgNam(NCar:NCar).eq.' ' .and. NCar.gt.1 ) NCar = NCar - 1 ENDDO call WC (' ') call WC ('=================================================') call WC 1 (' Fin de '//ProgNam(1:NCar)//' le '//cDate//' a '//cTime) call WC ('=================================================') call WC (' ') close (10) C =================================================================== RETURN end C =================================================================== SubRoutine RC (Prompt,Status,NVal,Texte,NCar) C =================================================================== C Le sous-programme RC realise la saisie d'une chaine de caracteres. C Slezak E, - Juillet 1990 C Prompt : Message d'interrogation. C Status : Peut-on avoir une valeur par defaut ([DE],NO) ? C NVal : Parametre ignore par ce sous-programme. C Texte : Texte fourni (les blancs en debut et en fin sont otes). C NCar : Nombre de caracteres de la chaine Texte ([0]). C =================================================================== character 1 Prompt*(*),Texte*(*), 1 Line*(80), 1 Status*2 logical*1 1 Default NCarM = 80 C ------------------------------------------------------------------- 100 format (1x,a,' > ',$) 110 format (Q,a) 200 format ('Vous devez repondre par un texte non nul.') 210 format ('Votre texte depasse 80 caracteres...') C ------------------------------------------------------------------- Default = .True. if ( Status.eq.'NO' .or. Status.eq.'no' ) then Default = .False. endif iPromptL = len( Prompt ) C =================================================================== 1000 CONTINUE WRITE (6,100) Prompt READ (5,110) NCar,Line if ( NCar.eq.0 ) then if ( Default ) then Texte = Line RETURN else WRITE (6,200) GOTO 1000 endif endif if ( NCar.gt.NCarM ) then WRITE (6,210) GOTO 1000 endif DO WHILE ( Line(NCar:NCar).eq.' ' .and. NCar.ge.1 ) NCar = NCar - 1 ENDDO ILast = NCar if ( ILast.eq.0 ) then ! Chaine nulle if ( Default ) then iFirst = 1 iLast = 1 else WRITE (6,200) GOTO 1000 endif else ICar = 1 DO WHILE ( Line(ICar:ICar).eq.' ' .and. ICar.lt.ILast ) ICar = ICar + 1 ENDDO iFirst = ICar ! 1er caractere du texte endif NCar = ILast - IFirst + 1 Texte = Line(IFirst:ILast) C =================================================================== RETURN end C =================================================================== SubRoutine RI (Prompt,Status,NVal_I,iArray,NVal_O) C =================================================================== C Le sous-programme RI realise la saisie d'entiers en Integer*4. C Slezak E. - Mars 1992 C Prompt : Message d'interrogation. C Status : Peut-on avoir une valeur par defaut ([DE],NO) ? C NVal_I : Nombre d'entiers a saisir. C iArray : Les differents entiers. C NVal_O : Nombre d'entiers saisis. C =================================================================== parameter 1 NIntegerM = 32, ! Nb max de valeurs saisies 1 IntegerF = 12 ! Entiers signes de 10 chiffres character 1 Prompt*(*), 1 Line*(NIntegerM*IntegerF),Texte*(NIntegerM*IntegerF), 1 Word(NIntegerM)*(IntegerF),Blank*(IntegerF), 1 Status*2 integer*4 1 iArray(1), 1 WordL(NIntegerM) logical*1 1 Default C ------------------------------------------------------------------- 100 format (1x,a,' > ',$) 110 format (Q,a) 200 format ('Vous devez repondre par une valeur numerique.') 210 format ('Le nombre maximum d''entiers ne peut depasser',i2) 220 format ('Un des nombres depasse les',i2,' digits permis.') 300 format (i) 310 format ('Erreur de format ! Veuillez retapez les donnees.') C ------------------------------------------------------------------- DO IC = 1,IntegerF Blank(IC:IC) = ' ' ENDDO Default = .True. if ( Status.eq.'NO' .or. Status.eq.'no' ) then Default = .False. endif iPromptL = len( Prompt ) C =================================================================== 1000 CONTINUE WRITE (6,100) Prompt READ (5,110) NCar,Line CALL SparseLine (Line,NCar,NWord,Word,WordL) if ( NWord.eq.0 ) then if ( Default ) then DO IVal = 1,NVal_I iArray(IVal) = 0 ENDDO NVal_O = 0 RETURN else WRITE (6,200) GOTO 1000 endif else if ( NWord.gt.NIntegerM ) then WRITE (6,210) NIntegerM GOTO 1000 endif endif DO IWord = 1,NWord WLength = WordL(IWord) if ( WLength.gt.IntegerF ) then WRITE (6,220) IntegerF GOTO 1000 endif iFirst = 1 + (IWord-1)*IntegerF iLast = IWord*IntegerF if ( WLength.eq.IntegerF ) then Texte(iFirst:iLast) = Word(IWord)(1:IntegerF) else NBlank = IntegerF - Wlength Texte(iFirst:iLast) = Blank(1:NBlank)//Word(IWord)(1:WLength) endif ENDDO decode (iLast,300,Texte,err=1100) (iArray(IVal), IVal=1,NWord) NVal_O = NWord RETURN 1100 CONTINUE WRITE (6,310) GOTO 1000 C =================================================================== end C =================================================================== SubRoutine RR (Prompt,Status,NVal_I,rArray,NVal_O) C =================================================================== C Le sous-programme RR realise la saisie de reels. C Slezak E. - Mars 1992 C Prompt : Message d'interrogation. C Status : Peut-on avoir une valeur par defaut ([DE],NO) ? C NVal_I : Nombre de reels a saisir. C rArray : Les differents reels. C NVal_O : Nombre de reels saisis. C =================================================================== parameter 1 NRealM = 16, ! Nb max de valeurs saisies 1 RealF = 16 ! Reels de 16 chiffres character 1 Prompt*(*), 1 Line*(NRealM*RealF),Texte*(NRealM*RealF), 1 Word(NRealM)*(RealF),Blank*(RealF), 1 Status*2 real*4 1 rArray(1) integer*4 1 WordL(NRealM) logical*1 1 Default C ------------------------------------------------------------------- 100 format (1x,a,' > ',$) 110 format (Q,a) 200 format ('Vous devez repondre par une valeur numerique.') 210 format ('Le nombre maximum de reels ne peut depasser',i2) 220 format ('Un des nombres depasse les ',i2,' digits permis.') 300 format (f.0) 310 format ('Erreur de format ! Veuillez retapez les donnees.') C ------------------------------------------------------------------- DO IC = 1,RealF Blank(IC:IC) = ' ' ENDDO Default = .True. if ( Status.eq.'NO' .or. Status.eq.'no' ) then Default = .False. endif iPromptL = len( Prompt ) C =================================================================== 1000 CONTINUE WRITE (6,100) Prompt READ (5,110) NCar,Line CALL SparseLine (Line,NCar,NWord,Word,WordL) if ( NWord.eq.0 ) then if ( Default ) then DO IVal = 1,NVal_I rArray(IVal) = 0. ENDDO NVal_O = 0 RETURN else WRITE (6,200) GOTO 1000 endif else if ( NWord.gt.NRealM ) then WRITE (6,210) NRealM GOTO 1000 endif endif DO IWord = 1,NWord WLength = WordL(IWord) if ( WLength.gt.RealF ) then WRITE (6,220) RealF GOTO 1000 endif iFirst = 1 + (IWord-1)*RealF iLast = IWord*RealF if ( WLength.eq.RealF ) then Texte(iFirst:iLast) = Word(IWord)(1:RealF) else NBlank = RealF - Wlength Texte(iFirst:iLast) = Blank(1:NBlank)//Word(IWord)(1:WLength) endif ENDDO decode (iLast,300,Texte,err=1100) (rArray(IVal), IVal=1,NWord) NVal_O = NWord RETURN 1100 CONTINUE WRITE (6,310) GOTO 1000 C =================================================================== end C =================================================================== SubRoutine RR8 (Prompt,Status,NVal_I,dArray,NVal_O) C =================================================================== C Le sous-programme RR8 realise la saisie de reels en double precision. C Slezak E. - Mars 1992 C Prompt : Message d'interrogation. C Status : Peut-on avoir une valeur par defaut ([DE],NO) ? C NVal_I : Nombre de reels a saisir. C dArray : Les differents reels. C NVal_O : Nombre de reels saisis. C =================================================================== parameter 1 NRealM = 16, ! Nb max de valeurs saisies 1 RealF = 16 ! Reels de 16 chiffres character 1 Prompt*(*), 1 Line*(NRealM*RealF),Texte*(NRealM*RealF), 1 Word(NRealM)*(RealF),Blank*(RealF), 1 Status*2 real*8 1 dArray(1) integer*4 1 WordL(NRealM) logical*1 1 Default C ------------------------------------------------------------------- 100 format (1x,a,' > ',$) 110 format (Q,a) 200 format ('Vous devez repondre par une valeur numerique.') 210 format ('Le nombre maximum de reels ne peut depasser',i2) 220 format ('Un des nombres depasse les ',i2,' digits permis.') 300 format (f.0) 310 format ('Erreur de format ! Veuillez retapez les donnees.') C ------------------------------------------------------------------- DO IC = 1,RealF Blank(IC:IC) = ' ' ENDDO Default = .True. if ( Status.eq.'NO' .or. Status.eq.'no' ) then Default = .False. endif iPromptL = len( Prompt ) C =================================================================== 1000 CONTINUE WRITE (6,100) Prompt READ (5,110) NCar,Line CALL SparseLine (Line,NCar,NWord,Word,WordL) if ( NWord.eq.0 ) then if ( Default ) then DO IVal = 1,NVal_I dArray(IVal) = 0.D0 ENDDO NVal_O = 0 RETURN else WRITE (6,200) GOTO 1000 endif else if ( NWord.gt.NRealM ) then WRITE (6,210) NRealM GOTO 1000 endif endif DO IWord = 1,NWord WLength = WordL(IWord) if ( WLength.gt.RealF ) then WRITE (6,220) RealF GOTO 1000 endif iFirst = 1 + (IWord-1)*RealF iLast = IWord*RealF if ( WLength.eq.RealF ) then Texte(iFirst:iLast) = Word(IWord)(1:RealF) else NBlank = RealF - Wlength Texte(iFirst:iLast) = Blank(1:NBlank)//Word(IWord)(1:WLength) endif ENDDO decode (iLast,300,Texte,err=1100) (dArray(IVal), IVal=1,NWord) NVal_O = NWord RETURN 1100 CONTINUE WRITE (6,310) GOTO 1000 C =================================================================== end C =================================================================== SubRoutine SparseLine (Line,NCarL,NWord,Word,WordL) C =================================================================== C Le sous-programme SparseLine decompose une ligne de texte en ses C differents mots. C Slezak E. - Mars 1992 C Line : Ligne de texte a traiter. C NCarL : Nombre de caracteres de la ligne de texte. C NWord : Nombre de mots qui la constituent. C Word : Les differents mots. C WordL : Longueur de chaque mot. C =================================================================== character*(*) 1 Line,Word(1) integer*4 1 WordL(1) C ------------------------------------------------------------------- NCar = NCarL NWord = 0 DO WHILE ( NCar.gt.0 ) DO WHILE ( Line(1:1).eq.' ' ) if ( NCar.eq.1 ) then RETURN else Line(1:NCar-1) = Line(2:NCar) NCar = NCar - 1 endif ENDDO NWord = NWord + 1 I_Blank = index( Line(1:NCar),' ') if ( I_Blank.eq.0 ) then Word(NWord) = Line(1:NCar) WordL(NWord) = NCar I_Blank = NCar + 1 else Word(NWord) = Line(1:I_Blank-1) WordL(NWord) = I_Blank-1 if ( I_Blank.lt.NCar ) then Line(1:NCar-I_Blank) = Line(I_Blank+1:NCar) endif endif NCar = NCar - I_Blank ENDDO C =================================================================== RETURN end C =================================================================== SubRoutine WC (Texte) C =================================================================== C Le sous-programme WC ecrit une chaine de caractere sur l'environnement. C Slezak E. - Juillet 1990 C =================================================================== character 1 Texte*(*) ! Ligne a ecrire C ------------------------------------------------------------------- 100 format (1x,a) C ------------------------------------------------------------------- NCar = len( Texte ) DO WHILE ( Texte(NCar:NCar).eq.' ' .and. NCar.gt.1 ) NCar = NCar - 1 ENDDO write (6,100) Texte(1:NCar) write (10,100) Texte(1:NCar) C =================================================================== RETURN end C =================================================================== SubRoutine WI (Prompt,iArray,NVal) C =================================================================== C Le sous-programme WI ecrit un tableau d'entiers en Integer*4 sur C l'environnement. C Slezak E. - Mars 1992 C Prompt : Message. C iArray : Tableau des valeurs. C NVal : Nombre de valeurs du tableau iArray. C =================================================================== character 1 Prompt*(*) integer*4 1 iArray(1) NValLM = 5 ! Nb maximal de valeurs par ligne IntegerF = 10 ! Entiers signes de 10 chiffres C ------------------------------------------------------------------- 100 format (1x,a,' : ',i) C ------------------------------------------------------------------- iPromptL = len( Prompt ) NLines = 1 + (NVal-1)/NValLM ! Nb de lignes necessaires DO ILine = 1,NLines iFirst = 1 + (ILine-1)*NValLM ! Premiere valeur iLast = min0( ILine*NValLM,NVal ) ! Derniere valeur NValL = iLast - iFirst + 1 ! Nombre de valeurs WRITE (6,100) Prompt,( iArray(IVal), IVal=iFirst,iLast ) WRITE (10,100) Prompt,( iArray(IVal), IVal=iFirst,iLast ) ENDDO C =================================================================== RETURN end C =================================================================== SubRoutine WR (Prompt,rArray,NVal) C =================================================================== C Le sous-programme WR ecrit un tableau de reels*4 sur l'environnement. C Slezak E. - Mars 1992 C Prompt : Message. C rArray : Tableau des valeurs. C NVal : Nombre de valeurs du tableau rArray. C =================================================================== character 1 Prompt*(*) real*4 1 rArray(1) RealFw = 16 ! RealFd = 8 ! huit chiffres significatifs NValLM = 4 ! Nb de valeurs par ligne C ------------------------------------------------------------------- 100 format (1x,a,' : ',g.) C ------------------------------------------------------------------- iPromptL = len( Prompt ) NLines = 1 + (NVal-1)/NValLM ! Nb de lignes necessaires DO ILine = 1,NLines iFirst = 1 + (ILine-1)*NValLM ! Premiere valeur iLast = min0( ILine*NValLM,NVal ) ! Derniere valeur NValL = iLast - iFirst + 1 ! Nombre de valeurs WRITE (6,100) Prompt,( rArray(IVal), IVal=iFirst,iLast ) WRITE (10,100) Prompt,( rArray(IVal), IVal=iFirst,iLast ) ENDDO C =================================================================== RETURN end C =================================================================== SubRoutine WR8 (Prompt,dArray,NVal) C =================================================================== C Le sous-programme WR8 ecrit un tableau de reels en double precision C sur l'environnement. C Slezak E. - Mars 1992 C Prompt : Message. C dArray : Tableau des valeurs. C NVal : Nombre de valeurs du tableau rArray. C =================================================================== character 1 Prompt*(*) real*4 1 dArray(1) RealFw = 25 ! RealFd = 17 ! 16 chiffres significatifs NValLM = 2 ! Nb de valeurs par ligne C ------------------------------------------------------------------- 100 format (1x,a,' : ',g.) C ------------------------------------------------------------------- iPromptL = len( Prompt ) NLines = 1 + (NVal-1)/NValLM ! Nb de lignes necessaires DO ILine = 1,NLines iFirst = 1 + (ILine-1)*NValLM ! Premiere valeur iLast = min0( ILine*NValLM,NVal ) ! Derniere valeur NValL = iLast - iFirst + 1 ! Nombre de valeurs WRITE (6,100) Prompt,( dArray(IVal), IVal=iFirst,iLast ) WRITE (10,100) Prompt,( dArray(IVal), IVal=iFirst,iLast ) ENDDO C =================================================================== RETURN end C =================================================================== SubRoutine WRE (Prompt,dArray,NVal) C =================================================================== C Le sous-programme WRE ecrit un tableau de reels double precision C sur l'environnement avec le format E. C Slezak E. - Mars 1992 C Prompt : Message. C dArray : Tableau des valeurs. C NVal : Nombre de valeurs du tableau rArray. C =================================================================== character 1 Prompt*(*) real*8 1 rArray(1) RealFw = 16 ! RealFd = 8 ! 16 chiffres significatifs NValLM = 4 ! Nb de valeurs par ligne C ------------------------------------------------------------------- 100 format (1x,a,' : ',e.) C ------------------------------------------------------------------- iPromptL = len( Prompt ) NLines = 1 + (NVal-1)/NValLM ! Nb de lignes necessaires DO ILine = 1,NLines iFirst = 1 + (ILine-1)*NValLM ! Premiere valeur iLast = min0( ILine*NValLM,NVal ) ! Derniere valeur NValL = iLast - iFirst + 1 ! Nombre de valeurs WRITE (6,100) Prompt,( dArray(IVal), IVal=iFirst,iLast ) WRITE (10,100) Prompt,( dArray(IVal), IVal=iFirst,iLast ) ENDDO C =================================================================== RETURN end