..
lit les données brutes, mais reste un commentaire datant de la lecture des tableaux:
$debug
c prendre date reele du susteme ....
c prevoir un vrai chemin
c gerer superposition en histo
c un seul histo
subroutine upcase(c)
character * 4 c
character * 1 c1
character * 3 c3
read(c,'(a1,a3)') c1,c3
if (c1 .ge. 'a' .and. c1 .le. 'z')
1 c1=char ( ichar(c1) - ichar('a') + ichar('A') )
write (c,'(a1,a3)') c1,c3
return
end
subroutine upcas1(c1)
character * 1 c1
character * 3 c3
if (c1 .ge. 'a' .and. c1 .le. 'z')
1 c1=char ( ichar(c1) - ichar('a') + ichar('A') )
return
end
function djvi(i,j)
if (j .eq. 0) djvi=0.0
if (j .ne. 0) djvi=(i*1.0)/j
return
end
function div(a,b)
real a,b
if (b .eq. 0.0) div=0.0
if (b .ne. 0.0) div=a/b
return
end
subroutine stpa(i,nom,date,imp)
character * 8 date
character * 4 nom(6)
c CALL STPA(IPA,NOMECH,IDD)
if (imp .ne.0) goto 10
write(0,1)
return
10 continue
write(imp,1) date,i
i=i+1
1 format(' Cevipof/Lasmas (CNRS) Construction ‚chelle de ',
1 'Loevinger ',a8,' page',i4/)
return
end
subroutine histo (p,iait,imp,nbit,mqz,numeit,iqorit,slmt)
dimension p(nbit),numeit(nbit),iqorit(nbit)
character * 8 mqz(nbit)
logical slmt
c si true seulement les presents
logical iait(nbit)
character * 1 tout(132) ,trecap(132)
logical prem
c240 CALL HISTO (P,IAIT,IMP,NBIT,MQ,numeit,iqorit)
write(*,*)
1 ' :',
2 ' 0 20 40 60 80 100:'
write(*,*)
1 '---------',
2 '---------------------------------------------------------'
prem=.true.
do 1141 iout=1,132
1141 trecap(iout)=' '
do 100 ibit=1,nbit
if (.not. prem) goto 140
c effacer la ligne
do 141 iout=1,132
141 tout(iout)=' '
prem=.false.
140 continue
c placer item sur la ligne
iout=5+ 50*p(ibit)
if (slmt .and. .not. iait(ibit) ) goto 300
if (iait(ibit)) goto 380
if (tout(iout).eq.' ') tout(iout)='-'
if (trecap(iout) .eq. ' ') trecap(iout)='-'
goto 381
380 continue
c mettre item present
if (tout(iout).eq.'+')tout(iout)='!'
if (tout(iout).eq.' ')tout(iout)='+'
trecap(iout)='+'
381 continue
inum=numeit(ibit)
310 iout=iout-1
if (inum .le. 0) goto 300
i1=inum/10
i1=inum - 10 *i1
inum=inum /10
if (tout(iout).eq.' ') goto 320
goto 300
320 continue
tout(iout)=char(ichar('0')+i1)
goto 310
300 continue
if (ibit .ne. nbit .and. iqorit(ibit).eq. iqorit(ibit+1))
1 goto 120
110 continue
c routine impression ligne
write(*,*) mqz(iqorit(ibit)),':',(tout(jout),jout=1,56),':'
prem=.true.
120 continue
100 continue
write(*,*)
1 '---------',
2 '---------------------------------------------------------'
write(*,*) ' ',':',(trecap(jout),jout=1,56),':'
return
end
c***************************************************** pp
DIMENSION NUMQ(99),MAK(99) , PP(6000)
INTEGER * 2 PP
EQUIVALENCE (LZ,NUIT)
CHARACTER * 4 IZIZ,IA,V,METHTA
character*8 mqz,mq
DIMENSION METHTA(20),MACH1(20),IVV(10),MQZ(99),MQ(100)
1,NUITTA(20)
1,NOMQ(99,6), IPOP(100)
CHARACTER * 4 NOMQ,IHY,IHZ,IHP,IVV
CHARACTER * 4 NOMECH(6),IBL
1 , IHA,IHC,IHD,IHE,IHG,IHL,IHM,IHS
2 ,METH
character * 1 meth1
DIMENSION IR(200)
CHARACTER * 8 IBL8,NOMCOP
character * 8 chemin
DIMENSION NOMCOP(500)
C ******* A REMETTRE A BONNE VALEUR
DOUBLE PRECISION IDA,NBJ
CHARACTER * 8 IDD,NOMCOD
DIMENSION NOMCOD(99,10)
DOUBLE PRECISION ICI(100),IWI(100),IC,IW,ICIJ,IWIJ,ICII,IWII,FDIV
DIMENSION CI(100),WI(100),P(100)
c iait a true si item present actuellelmment
LOGICAL IAIT (100)
c LV (item code) a true si le code inclu dans item
logical LV(100,10)
EQUIVALENCE(V,METH,IA)
LOGICAL MACHIN ,IMPINT ,LUTAB ,IMPIT,IMPIGN
character * 36 dsn,dsnlu
c variables ajoutess pour mot clefs
real tsave(20)
character*8 asave(20),proch,arappl,date
logical fini,partil
c
integer i4rep(20)
character * 4 a4rep(20)
c tableau des noms d'items
integer*4 numeit(100)
integer lircol(99)
c
c iqorit indique le ranq de la question dont est tir‚ item .
integer iqorit(100)
c tit indique le vecteur 0 ou 1 pour calculeer ni
c integer tit(100,10)
logical irepit(100)
c irepit profil un indu=vidu
character * 1 tlu(5000)
c pour lire une ligne fichier
character*80 dsndat,trav80 ,titre
c pour lire le fihcier de donness
logical lexist
c pour inquire
character * 4 mon,nom,mal
logical hseul,fa ,fotitr
logical fsaved
character * 1 acmd
C **
C **
C ----------------------- INITIALISATION DES CONSTANTES ALPHA .
DATA MAXIT/100/,MAXQ/99/,maxlig/5000/
DATA IBL8/' '/
DATA IHA,IHC,IHD,IHE,IHG,IHL,IHM,IHS /'A','C','D','E','G'
1 , 'L','M','S'/
DATA IHY,IHZ/'-','+'/
DATA IHP/'P'/
DATA NOMECH/6*' '/
IDINF(I,J)=(I*(I-1))/2+J
C ------------------------ AFFECTATION DES UNITES D ENTRE SORTIE
C EN CAS D UTILISATION AVEC UNE CONSOLE MAE ET MAL LA DESIGNENT
open(6,file='con')
fsaved=.true.
MAE=0
partil=.false.
c mae = machine ou operateur lit et programme ‚crit
IMP=6
IPA=1
hseul=.false.
minlrl=0
c notera la longuier de ligne neceszsaire
C ******
if (lca .eq. 0) CALL STPA(IPA,NOMECH,IDD,lca)
CALL STPA(IPA,NOMECH,IDD,imp)
write(0, 3001)
3001 FORMAT('0VERSION AU 19 5 72,',
1 ' MS Fortran du 22/8/88 KHI2 ET C, W, H, EN DOUBLE PRECIS.'/
2 ' Version mot-clef du 14 Juillet 1991 ');
write(*,*)
write(0,*) 'en g‚n‚ral, vous pourrez obtenir de l''aide en'
1 , ' frappant ?<return>'
write(*,*) 'entr‚e ?'
write(*,*)
1 'nom_de_fichier<RETURN> si vous avez pr‚par‚ votre ‚chelle'
write(*,*)
1 ' con<RETURN> pour travailler en conversationnel'
read(*,'(a)') dsn
lca=3
read(dsn,'(3A1)') (tlu(j),j=1,3)
do 3002 j=1,3
call upcas1(tlu(j))
3002 continue
if (tlu(1).eq.'C'.and.tlu(2).eq.'O'.and.tlu(3).eq.'N') lca=0
c lecture de la carte date (une seule par execution )
if (lca .eq. 0) goto 3008
inquire(file=dsn,exist=lexist)
if (lexist) goto 3007
write(*,*) 'fichier ',dsn,' pas trouv‚'
stop
3007 continue
open(3,file=dsn,form='formatted',status='old')
3008 continue
call anal(lca,
1 'LOEVINGR: CHEMIN: , DATE: , RAPPEL: , TITRE ; ',
2 tsave,asave,4,fini,.true.)
chemin=asave(1)
date=asave(2)
arappl=asave(3)
fotitr=tsave(4).ne.0
write(*,*) 'fotitr=',fotitr
read(chemin,'(8a1)') (tlu(jlu),jlu=1,8)
do 61011 jfchmn=1,8
if (tlu(jfchmn) .ne. ' ') goto 61012
61011 continue
c fuul espace nom
jfchmn=8
goto 61014
61012 continue
c non espace trouve reecrire en tete
if (jfchmn .gt. 1)
a write(chemin,'(8a1)') (tlu(ifchmn),ifchmn=jfchmn,8),
1 (' ',ifchmn=1,jfchmn-1)
jfchmn=9-jfchmn
c cas ordinaire
goto 61013
c espace en pposition 1
61014 write(*,*) 'sauvegarde impossible'
goto 61013
61013 continue
c write(*,*) 'jfchmn=',jfchmn,'====',chemin,'===='
C ******
C **
C **
671 CONTINUE
C ******************** D R OU B
199 CONTINUE
nob=1
write(*,*) 'arappel=',arappl,'======='
if (arappl.eq.' ') GO TO 66
c 12345678
c reprise
read(arappl,'(a1,6x,a1)') tlu(1),tlu(2)
write(*,*) ichar(tlu(1)),ichar(tlu(2))
if (tlu(1).eq. ' ' .and. tlu(2).eq. ' ') goto 66
read(chemin,'(8a1)') (tlu(jche),jche=1,8)
write(*,*) 'on va faire un read interne de ====',nom,'==='
read(arappl ,'(5x,3a1)') (tlu(jche),jche=9,11)
write(dsn,'(12a1)')( tlu(jche),jche=1,jfchmn),'.',
1 (tlu(jche),jche=9,11)
50372 continue
write(0,*) 'lecture de ',dsn
dsnlu=dsn
inquire(file=dsn,exist=lexist)
if (lexist) goto 50732
write(*,*) 'fichier ',dsn,' pas trouv‚'
stop
50732 continue
open(10,file=dsn,form='unformatted',status='old')
C *******************
READ(10)NOMECH,NBI,NBQ,NBIT,LV,
1 (pp(jjpo),jjpo=1,nbit*(nbit+1)/2 ) ,MQ,NOMCOD,NOMQ,MAK,IDA,
1 NBPAS,MQZ,iait,nitp,p,ipop,iwi,ici,ic,iw
read(10)
1 (numeit(jjpo),iqorit(jjpo),jjpo=1,nbit)
close( 10)
fsaved=.true.
C *******************
NBPAS=NBPAS+1
CALL STPA(IPA,NOMECH,IDD,imp)
WRITE(IMP,1010) IDA ,NBPAS
1010 FORMAT(' SUITE DU ' , A8,I3,' EME PASSAGE ');
nbord=0
GO TO 203
C ******
C ****
C * * * * * * * * * * * * NOUVELLE ECHELLE ( D )
C **
66 CONTINUE
c lecture carte echelle a mot clef
c nbit sera cumule depuis les items
titre=' '
if (.not. fotitr) goto 66066
call lianum('TITR',lca,'TITRE: ...;',i4rep,20,a4rep,20,nob)
write(trav80,'(20a4)') (a4rep(jt),jt=1,20)
read(trav80,'(a80)') titre
66066 continue
call anal(lca,
1 'ECHELLE: IMPIT ; ',
2 tsave,asave,2,fini,.true.)
if (.not. fini) goto 6605
write(*,*)'***** fin de fichier en lecture echelle'
stop
6605 continue
IMPIT= tsave(1).ne.0
c
c
c pour eviter controle
c write(*,*) 'contruction nouvelle echelle'
c write(*,*) 'lecture des question '
nob=1
call lianum('TITR',lca,'INFILE: ...;',i4rep,20,a4rep,20,nob)
c convertir en string 1
c write(*,*) 'retour de lianum titre nob=',nob
write(trav80,'(20a4)') (a4rep(jt),jt=1,20)
read(trav80,'(a80)') dsndat
write(*,*)'dsndat=',dsndat
nbq=0
IF( MOD(I,25).EQ.0.AND.IMPIT)CALL STPA(IPA,NOMECH,IDD,imp)
70 continue
c write(*,*) 'est ce une question ?'
call testun(lca,proch,'QUESTION ou autre;')
70000 ia=' '
if (proch.ne.'QUESTION') goto 70999
c encore une question
c write(*,*) 'oui'
call anal(lca,
1 'QUESTION: NOM: , COL= , MAX= ;',
2 tsave,asave,3,fini,.true.)
if (fini) goto 665
GOTO 666
665 WRITE(MAE,'('' FIN DE FICHIER SUR UNITE LOGIQUE '',I3,
1 '' EN LISANT QUESTION'')') LCA
STOP
666 CONTINUE
c do 66601 jlist=1,3
c 66601 write(*,*) jlist,' ',tsave(jlist),' ',asave(jlist)
if (nbq .lt. maxq) goto 66608
write(*,*) 'le programme est limit‚ … ',maxq,' questions'
stop
66608 continue
nbq=nbq+1
i=nbq
mak(i)=tsave(3)
if (mak(i) .gt. 0) goto 66680
write(*,*) 'maximum nul ci dessus'
stop
66680 continue
nbitdq=0
mqz(i)=asave(1)
lircol(i)=tsave(2)
if (lircol(i) .gt.0) goto 66637
write(*,*) 'code col= manquant ou nul ci dessus'
stop
66637 continue
if (lircol(i) .gt. minlrl) minlrl=lircol(i)
c mqz passe en alpha
IF(IMPIT)WRITE(IMP,72) I,MQZ(I),(NOMQ(I,J),J=1,6),MAKJ ,(NOMCOD(I
1,J),J=1,MAKJ)
72 FORMAT(1H0,I7,' Q=',a8,1X,6A4,1X,I2,10(1x,A3))
c ici vien la lecture des items deduits de la question
70777 continue
call testun(lca,proch,'ITEM, QUESTION ou autre;')
ia=' '
if (proch.ne.'ITEM') goto 70888
c encore une question
if (nbit .lt. maxit) goto 70666
write(*,*) 'le programme est limit‚ … ',maxit,' items'
stop
70666 continue
nbit=nbit+1
nob=1
nob=2
call lianum('NUME',lca,
1 'ITEM: ;',i4rep,100,a4rep,100,nob)
c write(*,*) 'memoriser item nombre:',nob
if (i4rep(1) .gt. 0) goto 70333
write(*,*) 'numero item nul ou manquant ci dessus'
stop
70333 continue
numeit(nbit)=i4rep(1)
c verifier dupplication
if (nbit .le. 1) goto 70706
do 70709 jbit=1,nbit-1
if (numeit(nbit) .eq. numeit(jbit)) goto 70708
70709 continue
goto 70706
70708 continue
write(*,*) 'numero d''item duppliqu‚ ci dessus'
stop
70706 continue
c question origine de l'item
iqorit(nbit)=i
do 72089 icode = 1,10
lv(nbit,icode)=.false.
72089 continue
c tit(nbit,icode)=0
do 72091 icode = 2 , nob
if (i4rep(icode).gt.9) write(*,*) 'hors code !'
c if (i4rep(icode) .ge. 0 .and. i4rep(icode).le.9)
c 1 tit(nbit,i4rep(icode)+1)=1
if (i4rep(icode) .ge. 0 .and. i4rep(icode).le.9)
1 lv(nbit,i4rep(icode)+1)=.true.
72091 continue
goto 70777
70888 continue
c on a une suivante non item
c ancine 70 sur question
goto 70000
70999 continue
c write(*,*) 'ligne non question, on change'
DO 92 I=1,MAXIT
92 IAIT(I)=.FALSE.
c ici etait ancienne boucle sur les items
write(*,*) 'Comptage en cours ....'
if (minlrl .le. 1000) goto 709
write(*,*) 'le programme est limite … LRECL=1000'
stop
709 continue
nbi=0
c ouverture fichier
c write(*,*)' on va lire ',dsndat
inquire(file=dsndat,exist=lexist)
if (lexist) goto 70997
write(*,*) 'fichier ',dsndat,' pas trouv‚'
stop
70997 continue
if (minlr .le. maxlig) goto 70991
write(*,*) 'la longueur de ligne est limit‚e … ',maxlig
stop
70991 continue
open(10,file=dsndat,form='formatted')
c write(*,*) 'fichier de donnes ouvert '
c sera incremente
NBNB=(NBIT*(NBIT+1))/2
DO 7099 J=1,NBNB
7099 PP(J)=0
710 continue
read(10,'(5000a1)',end=700) (tlu(jlu),jlu=1,minlrl)
goto 720
700 continue
write(*,*) 'fin de fichier individus nbi=',nbi
if (nbi .gt. 1) goto 780
write (0,*)' fichier individu vide !'
stop
720 continue
nbi=nbi+1
do 721 iit=1,nbit
c a priori la reponse de l'individu est non
irepit(iit)= .false.
irepq=ichar(tlu(lircol(iqorit(iit))))-48
if (irepq.eq.-16) irepq=0
if (irepq.ge.0 .and. irepq .le.9) goto 722
write(*,*) 'item rang ',iit, ' reponse :',irepq
write(*,*) 'individu:',nbi,' rang item:',iit ,' rang question:',
1 iqorit(iit),' colonne orig:',lircol(iqorit(iit))
stop
722 continue
c irepq est la reponse
if ( lv(iit,1+irepq) ) irepit(iit)= .true.
721 continue
c if (irepit(1).ne.0 )
c 1 write(*,'(1x,10i1)') (irepit(iit),iit=1,nbit)
do 741 iit=1,nbit
do 741 jjt=1,iit
if ( .not. (irepit(iit) .and. irepit(jjt))) goto 741
742 continue
idinfx=idinf(iit,jjt)
c ++
PP(IDINFx)=PP(IDINFx)+1
c IDINF(I,J)=(I*(I-1))/2+J
741 continue
goto 710
780 continue
c write(*,*) 'fin de comptage, tableau de tri nij'
do 7909 iit=2,nbit
do 7909 jjt=1,iit -1
if (pp(idinf(iit,iit)) .gt. pp(idinf(jjt,jjt)))
1 pp(idinf(iit,jjt))=pp(idinf(jjt,jjt))-pp(idinf(iit,jjt))
if (pp(idinf(iit,iit)) .le. pp(idinf(jjt,jjt)))
1 pp(idinf(iit,jjt))=pp(idinf(iit,iit))-pp(idinf(iit,jjt))
7909 continue
close(10)
GO TO 1100
C
c ******** on nepasse pas la .....
c reprise
11060 continue
c debut
IF(METH .EQ. 'D ') GO TO 660
write(*,*) ' fin fatale'
IF(IMPIGN)WRITE(IMP,1105)METH,NOM
1105 FORMAT(20H CARTE IGNOREE ,A1,A3,19A4)
1109 continue
stop
660 continue
1100 continue
c NBNB=(NBIT*(NBIT+1))/2
c DO 99 J=1,NBNB
c 99 PP(J)=0
C
C
C ---------------- DEBUT DE LA BOUCLE DE LECTURE DES TQBLEAUX
998 CALL STPA(IPA,NOMECH,IDD,imp)
C ******
C ****
C **
LUTAB=.TRUE.
PP (IDINF (KL,KL ))=IPL
PP (IDINF (KC,KC ))=IPC
NBJ=NBI
c
C ******
C ****
C **
C **
C ****
C ******
C ---------------------- CHOIX DE LA METHODE AD OU SOUS
C ******
C ****
C **
C **
C ****
C ******
fsaved=.false.
213 continue
write(mae,21299)
21299 format(/'? ( A, S, Tn, Kabc) ou ? '/)
21355 READ(lca,'(80a1)',END=20209) (tlu(jlu),jlu=1,80)
if (lca.ne.0) write(*,'(1x,80a1)') (tlu(jlu),jlu=1,80)
c eliminer commentaires
c avance … non espace
jprem=0
21888 jprem=jprem+1
if (tlu(jprem).eq.' ' .and. jprem .lt. 79) goto 21888
if (tlu(jprem).eq. '*') goto 21355
meth1=tlu(jprem)
call upcas1(meth1)
c call upcase(meth)
c ====
if (meth1 .eq. 'C' ) lca=0
if (meth1 .eq. 'C' ) nbord=0
if (meth1 .eq. 'C' ) write (0,*) 'entr‚e au clavier'
if (meth1 .eq. 'C' ) goto 213
if (meth1 .eq. 'P') partil=.true.
if (meth1 .eq. 'F') partil=.false.
if (meth1 .eq. 'P' .or. meth1 .eq. 'F') write(*,*) partil
if (meth1 .eq. 'P' .or. meth1 .eq. 'F') goto 213
c=====
if (meth1 .ne. '?') goto 21380
write(0,*) ' Help, (astek) d‚veloppement en cours'
write(0,*) ' C donne la main au clavier'
write(0,*) ' A partir/repartir en avec aucun item pr‚sent'
write(0,*) ' S partir/repartir avec tous les items pr‚sents'
write(0,*) ' Tx donner un triangle '
write(0,*) ' Nij Cij Wij Hij'
write(0,*) ' Kabc conserver cette ‚chelle avec le nom chemin.abc'
write(0,*) ' K conserver une ‚chelle avec son nom original'
write(0,*) ' Q quitter le programme'
goto 213
21380 continue
214 continue
c write(*,*) 'vaudrait mieux se taire'
c WRITE(IMP,200)METH,NUIT
c 200 FORMAT('0A LA QUESTION A, S, T, K, Q, VOUS AVEZ REPONDU ',A1,I3)
IF(METH1 .ne. 'T') GO TO 568
meth1=tlu(jprem+1)
call upcas1(meth1)
nuit=0
if (meth1 .eq. 'N') nuit=1
if (meth1 .eq. 'C') nuit=2
if (meth1 .eq. 'W') nuit=3
if (meth1 .eq. 'H') nuit=4
if (nuit .ne. 0) goto 20011
write(*,*)'La commande T doit etre suivie d''une lette: N C W H!'
goto 213
20011 continue
CALL IMPTAB(NBIT,PP,NUIT,IAIT,IPOP,NBI,NOMECH,numeit,partil)
GO TO 213
568 continue
if (METH1 .NE. 'Q') goto 50139
if (fsaved) goto 50135
write(*,*)
50131 continue
write(*,*) 'quit demand‚, dernieres operatrions non sauv‚es'
write(*,*) 'repondez E(nd) ou A(bandon)'
read(*,'(a1)') acmd
call upcas1(acmd)
if (acmd.ne. 'A' .and. acmd .ne. 'E')
1 goto 50131
if (acmd .eq. 'E') goto 50135
if (acmd .eq. 'A') goto 213
c donc acmd= s
50135 continue
stop
50139 continue
IF (METH1 .EQ. 'K')NOM=MON
IF (METH1 .EQ. 'K')GO TO 101
IF(METH1 .NE. 'A' .AND. METH1 .NE. 'S')
1 write(*,*) 'il faut choisir une methode A/S'
IF(METH1 .NE. 'A' .AND. METH1 .NE. 'S')
1 GO TO 213
write(0,*) 'initialisation ',meth1
fsaved=.false.
NITP=0
IC=0.D0
IW=0.D0
NBORD=0
DO 202 I=1,NBIT
if (nbi .eq. 0) write (0,*)' nbj nul, cela va mal se passer'
P(I)=(1.*PP(IDINF(I,I)))/NBI
IPOP(I)=PP(IDINF(I,I) )
IWI(I)=0.D0
ICI(I)=0.D0
202 IAIT(I)=METH1 .EQ. 'S'
IF(METH1 .EQ. 'A') GO TO 203
c comptage initial du S
NITP=NBIT
c write(*,*) 'calcul en 222'
DO 223 I=1,NBIT
ICII=0.D0
IWII=0.D0
DO 222 J=1,NBIT
IF (iqorit(I) .EQ. iqorit(J)) GO TO 222
IWII=IWII+MIN0(IPOP(I),IPOP(J))*(NBI-MAX0(IPOP(I),IPOP(J)))
IF(J .GE. I) GO TO 224
ICII=ICII+PP(IDINF(I,J))
GO TO 222
224 ICII=ICII+PP(IDINF(J,I))
222 CONTINUE
IWI(I)=IWII
IW=IW+IWII
IC=IC+ICII
ICI(I)=ICII
c write(*,*) 'li:',i,' ici(i):',ici(i),' iwi(i):',iwi(i)
223 continue
write(*,*) 'ic=',ic,' iw=',iw
METH=IHL
c continuer en faisant uine liste
meth1='L'
GO TO 230
C POUR LISTER L ECHELLE ET CALCULER LE H
C ******
C ****
C -------------------------- DONNEZ VOTRE ORDRE
c si on a de l'avance traiter sasn lire
203 continue
20399 continue
c write(mae,21399)
c READ(lca,204,END=20208)V,MON,(METHTA(J),NUITTA(J),J=1,1)
c 204 FORMAT (A1,A3,8(1X,A1,I3))
21255 continue
c if (lca .eq. 0) write (*,*) 'lire en 21255'
if (lca .eq. 0) write(*,*) '?'
READ(lca,'(80a1)',END=20209) (tlu(jlu),jlu=1,80)
if (lca.ne.0) write(*,'(1x,80a1)') (tlu(jlu),jlu=1,80)
c eliminer commentaires
c avance … non espace
jprem=0
21288 jprem=jprem+1
if (tlu(jprem).eq.' ' .and. jprem .lt. 79) goto 21288
if (tlu(jprem).eq. '*') goto 21255
meth1=tlu(jprem)
call upcas1(meth1)
c write(*,*) 'commande:',meth1
if (meth1 .ne. '?') goto 21388
write(0,*) ' Help, (full) d‚veloppement en cours'
write(0,*) ' C donne la main au clavier'
write(0,*) ' L donne le profil actuel '
write(0,*) ' P changement de page imprimante'
write(0,*) ' A partir/repartir en avec aucun item pr‚sent'
write(0,*) ' S partir/repartir avec tous les items pr‚sents'
write(0,*) ' T donner un triangle .'
write(0,*) ' Nij Cij Wij Hij'
write(0,*) ' Kabc conserver cette ‚chelle avec le nom chemin.abc'
write(0,*) ' K conserver une ‚chelle avec son nom original'
write(0,*) ' ... '
goto 203
21388 continue
LZ=NUITTA(1)
if (meth1 .ne. 'C') goto 10130
lca=0
nbord=0
write(0,*) 'entr‚e au clavier'
goto 203
10130 continue
if (METH1 .NE. 'Q') goto 10139
if (fsaved) goto 10132
write(*,*) 'quit demand‚, ‚chelle non sauv‚e'
10133 write(*,*) 'frappez A(bandon) ou E(nd)'
read(*,'(a1)') acmd
call upcas1(acmd)
if (acmd.eq. 'E') goto 10132
if (acmd.eq. 'A') goto 203
goto 10133
10132 continue
stop
10139 continue
IF(METH1 .EQ. 'K')GO TO 101
c dito
IF(meth1 .EQ. 'L') GO TO 230
c IF(meth1 .EQ. 'P') CALL STPA(IPA,NOMECH,IDD,imp)
c IF(meth1 .EQ. 'P') GO TO 203
IF(meth1 .NE. 'T') GO TO 555
nuit=0
meth1=tlu(jprem+1)
call upcas1(meth1)
if (meth1 .eq. 'N') nuit=1
if (meth1 .eq. 'C') nuit=2
if (meth1 .eq. 'W') nuit=3
if (meth1 .eq. 'H') nuit=4
if (nuit .ne. 0) goto 21111
write(*,*)'La commande T doit etre suivie d''une lette: N C W H!'
goto 203
21111 continue
CALL IMPTAB(NBIT,PP,NUIT,IAIT,IPOP,NBI,NOMECH,numeit,partil)
write(*,*) ' '
GO TO 203
555 IF(meth1 .EQ. 'A' .OR. meth1 .EQ. 'S'
1 ) GOTO 214
C **
C ****
C ******
IF(METH1.EQ.IHP)CALL STPA(IPA,NOMECH,IDD,imp)
IF(METH1.NE.IHY.AND.METH1.NE.IHZ)GO TO 205
C ----------------------- AJOUTE OU OTER UN ITEM
c prendre le numero d'item
c ici faut decode nombre
nuit=0
20077 jprem=jprem+1
if (tlu(jprem).eq.' ' .and. jprem .lt.80) goto 20077
c construire l nopmbre
20075 if (tlu(jprem) .lt. '0' .or. tlu(jprem) .gt. '9') goto 20076
nuit=10*nuit+ichar(tlu(jprem))-ichar('0')
jprem=jprem+1
goto 20075
20076 if (tlu(jprem ) .eq. ' ')goto 20074
write(*,*) 'La commande +/- est suivie d''un nombre invalide'
goto 203
20074 continue
c convertir nuit
do 11080 iuit=1,nbit
if (nuit .eq. numeit(iuit)) goto 11081
11080 continue
write(*,*) 'le numero d''item demand‚ n''esiste pas'
goto 203
11081 continue
nuit=iuit
IF(METH1.EQ.'+' .AND.IAIT(NUIT) ) GO TO 206
IF(METH1.EQ.'-'.AND. .not. IAIT(NUIT)) goto 206
GO TO 208
206 WRITE(MAE,209) numeit(NUIT)
209 FORMAT(1H ,I4,' ITEM A OTER ABSENT OU AJOUTER PRESENT' )
GO TO 203
208 IAIT(NUIT)= .not. iait(nuit)
fsaved=.FALSE.
IS=-1
IF (IAIT (NUIT))IS=+1
NITP=NITP+IS
c write(*,*) ' calcul en 211'
DO 211 I=1,NBIT
c
c voir ce qui etait ciic
IF (iqorit(I) .EQ. iqorit(nuit)) GO TO 211
IWIJ=IS*MIN0(IPOP(I),IPOP(NUIT))*(NBI-MAX0(IPOP(I),IPOP(NUIT)))
IF(I .LE. NUIT) ICIJ=PP(IDINF(NUIT,I))
IF(I .GT. NUIT) ICIJ=PP(IDINF(I,NUIT))
ICI(I)=ICI(I)+IS*ICIJ
IWI(I)=IWI(I)+IWIJ
IF( .NOT. IAIT(I)) GO TO 211
IC=IC+2*IS*ICIJ
IW=IW+2*IWIJ
211 CONTINUE
c write(*,*) ' au dela de 211 ic=',ic,' iw=',iw
c continuer en donnant le H...
hseul=.true.
GO TO 230
C -------------------------- AUTRES COMANDES
205 continue
if (meth1 .eq. 'P') partil=.true.
if (meth1 .eq. 'F') partil=.false.
if (meth1 .eq. 'P' .or. meth1 .eq. 'F') write(*,*) partil
if (meth1 .eq. 'P' .or. meth1 .eq. 'F') goto 203
IF(METH1.EQ.'G')GO TO 240
IF(METH1 .EQ. 'L')GO TO 230
C ----------------------- COMMMANDE INEXISTANTE
if (meth1 .ne. ' ') WRITE(MAE,242) meth1
242 FORMAT(' WAT DO IOU OUANT ',a4 )
GO TO 203
C --------------------- DEMANDE DU GRAPHIQUE HIJ, P%I.
240 continue
CALL HISTO (P,IAIT,IMP,NBIT,MQz,numeit,iqorit,partil)
GO TO 203
C --------------------- CALCUL DE H
230 continue
IF(NITP .LE. 1) GO TO 235
FDIV=NITP*NITP
FDIV=FDIV*NBI
c write(*,*) 'en 230 ic=',ic,' fdiv=',fdiv
c write(*,*) 'frappre return'
c read(*,*)
C=IC/FDIV
W=IW/(FDIV*NBI)
c WRITE(MAE,*) ic,iw,C,W,NITP
H=1-div (C,W)
WRITE(MAE,232) H,C,W,NITP
232 FORMAT('0H=',F6.3,3X,'(C=',F6.3,' W=',F6.3,') ',I5,' ITEMS PRESE
1NTS')
235 continue
IF(METH1 .NE. 'L')GO TO 203
c ancienne ligne ci dessous on ne pouvait faire liste si 0 item presents
c IF(METH .NE. 'L '.OR.NITP.EQ.0)GO TO 203
C ----------------------- LISTE DES ITEMS PRESENTS
526 CALL STPA(IPA,NOMECH,IDD,imp)
WRITE(IMP,232)H,C,W,NITP
WRITE(IMP,251)
251 FORMAT(43H0IT C(I) W(I) P(I) H(I) ET SI )
FDIV=NBI*NITP
DO 250 I=1,NBIT
C C =ICI(I)/(1.*NBI*NITP)
C W =IWI(I)/(1.*NBI*NBI*NITP)
c ci desous mis div
c C=ICI(I)/FDIV
c W=IWI(I)/(FDIV*NBI)
fsdiv=fdiv
fci=ici(i)
c en simple precision
C=div(fci,FsDIV)
fci=iwi(i)
W=div(fci,(FsDIV*NBI) )
HP=1-DIV(C,W)
c HP=1-C/W
IS=2
IF(IAIT(I))IS=-2
cc1= 1.0*IC+IS*ICI(I)
cc2= (1.0*IW+IS*IWI(I))/NBI
HPP=1-div( cc1,cc2 )
c HPP=1- (IC+IS*ICI(I))/((IW+IS*IWI(I))/NBI)
IF(i .ne.1 .and. iqorit(i) .eq. iqorit(i-1) )GO TO 550
C CHERCHER LA QUESTION DE L ITEM
j=iqorit(i)
MAKJ=MAK(J)
c WRITE(IMP,254)MQ.....(I),(NOMQ(J,K),K=1,6)
WRITE(IMP,254)MQz(j),(NOMQ(J,K),K=1,4)
c 4 au lieu de 6 :::::
254 FORMAT(' ',50X,a8,1X,6A4)
550 continue
c mettre le vecteur des codes presents
DO 553 JJ=0,MAKJ
NOMCOP(JJ+1)=IBL8
IVV(JJ+1)=IHY
IF (.NOT. LV(I,JJ+1)) GO TO 553
IVV(JJ+1)=char(jj+48)
NOMCOP(JJ+1)=NOMCOD(J,JJ+1)
553 CONTINUE
250 WRITE(IMP,252)numeit(I),
1 C ,W ,P(I),HP,HPP , IAIT(I),
c 2 (IVV(K+1),NOMCOP(K+1), K=0,MAKJ)
c 2 (IVV(K+1), K=0,MAKJ)
252 FORMAT(1x,I4,3F8.3, 2F8.3,3X,L1,3X,10(1X,A1,1x))
write(*,*) ' '
GO TO 203
9999 STOP
101 CONTINUE
c le dsn est de jprem+1 … espace
dsn=dsnlu
write(mon,'(3A1)') (tlu(jprem+ilu),ilu=1,3)
if (mon .eq. ' ') goto 10144
write(*,*) 'jfchmn=',jfchmn
read(chemin,'(8a1)') (tlu(jche),jche=1,8)
read(mon ,'(3a1)') (tlu(jche),jche=9,11)
write(dsn,'(12a1)')( tlu(jche),jche=1,jfchmn),'.',
1 (tlu(jche),jche=9,11)
10144 continue
WRITE(MAE,'(/'' MEMORISATION SUR DISQUE dans '',a12/)') dsn
C *******************
if (dsn .ne. dsnlu) goto 10101
write(*,*) 'sauvegarde sur le meme en old donc'
open (10,file=dsn,form='unformatted',status='old')
goto 10102
10101 continue
write(*,*) 'sauvegarde different'
inquire(file=dsn,exist=lexist)
if (lexist) goto 10103
write(*,*) 'fichier ',dsn,' pas trouv‚, on le cr‚e'
open (10,file=dsn,form='unformatted',status='new')
goto 10102
10103 continue
write(*,*) 'on pourrait demande confirmation '
open (10,file=dsn,form='unformatted',status='old')
10102 continue
WRITE(10)NOMECH,NBI,NBQ,NBIT,LV,
1 (pp(jjpo),jjpo=1, nbit*(nbit+1)/2 ) ,MQ,NOMCOD,NOMQ,MAK,IDD,
1 NBPAS,MQZ,iait,nitp,p,ipop,iwi,ici,ic,iw
write(10)
1 (numeit(jjpo),iqorit(jjpo),jjpo=1,nbit)
close(10)
C *******************
GO TO 203
2030 WRITE(IMP,2031) MAXIT,MAXQ
2031 FORMAT('0 ERREUR SUR LA CARTE ECHELLE CI DESSUS, MAXIT= ',I3,
1' ,MAXQ= ',I3)
stop
20209 WRITE(IMP,2021) lca
2021 FORMAT('0FIN DE FICHIER TROUVEE SUR LE FICHIER ',i3,', STOP'/)
if (lca .eq. 0) stop
lca=0
goto 213
20208 WRITE(IMP,2021) lca
if (lca .eq. 0) stop
lca=0
goto 20399
END
C ANCIENNE VERSION SAUVEE AVANT MODIF 8 7 86
c sans savoir ce que sont ces modifs ... 21 8 88
SUBROUTINE IMPTAB(NBIT,PP,LUIT,IAIT,IPOP,NBI,NOMECH,
1 nmi,partil )
LOGICAL IAIT (1) ,partil
DIMENSION ILIGNE(25) ,PP(1) ,NOMECH(6)
INTEGER * 2 PP
CHARACTER * 4 NOMECH
CHARACTER * 4 ITEXT
DIMENSION ITEXT(5)
dimension nmi(nbit)
DATA ITEXT/'N IJ','C IJ','W IJ','H IJ','++ '/
MUIT=MOD(LUIT,100)
NUIT=MOD(MUIT,10)
NBCO=15
C REDUIT A 20 CI DESSUS
C
write(*,*) 'partiel=',partil
IF (LUIT .GT.100) NBCO=20
IF(NUIT .GT. 0 .AND. NUIT .LE. 4) GO TO 7
write(0, 6) NUIT
6 FORMAT('-* * * * * VALEUR ILLEGALE POUR T NUIT=',I5)
RETURN
7 IP=0
c boucle sur les l‚s
DO 1 JCOG=1,NBIT,NBCO
NBLI=NBCO
IF (MUIT .GT. 10) NBLI=2000
c boucle sur les colonnes
DO 2 JL1H=JCOG,NBIT,NBLI
JLIH=JL1H
JLIB=MIN0(NBIT,JLIH+NBLI-1)
JCOE=MIN0(NBIT,JCOG+NBCO-1)
IP=IP+1
write(0, 8) ITEXT(NUIT),NOMECH ,IP,nmi(JCOG),nmi(JCOE),
1 nmi(JLIH),nmi(JLIB)
8 FORMAT('1TABLEAU ',A8,6A4,'PAGE ',I3,I9,' A ',I3,' PAR ' ,I3,' A
1 ',I3)
write(0, 9) (nmi(JJ),JJ=JCOG,JCOE)
9 FORMAT('- ',25(I4,':'))
IF(JLIH.EQ.1.AND.NUIT.NE.1)JLIH=2
DO 3 JLI=JLIH,JLIB
IF(partil .AND. .NOT. IAIT(JLI)) GO TO 3
JCOD= MIN0(JCOE,JLI)
jcodav=jcod
IF (NUIT .NE. 1 .and. jcod .eq. jli)JCOD=JCOD-1
c write(*,*) 'jcodav=',jcodav ,' jli=',jli ,' jcod=',jcod
C MODIF CI DESSUS 8 JUILLET MEME POUR LIGNE DU BAS
NBNB=JCOD-JCOG+1
c write(*,*) 'jcog=',jcog,' jcod=',jcod ,' nbnb=',nbnb ,'jcoe:',
c 1 jcoe,' jli:',jli
DO 33 JCO=JCOG,JCOD
JJ=JCO-JCOG+1
IFROM=(JLI*(JLI-1) ) /2+JCO
JLIFR=JLI*(JLI+1)/2
JCOFR=JCO*(JCO+1)/2
C 1 => NIJ 2=> C IJ 3=> W IJ 4=> H IJ 5 n++
MARG1=PP(JLIFR)
MARG2=PP(JCOFR)
MIN=MIN0(MARG1,MARG2)
MAX=MAX0(MARG1,MARG2)
WIJ=100.* djvi(MIN*(NBI-MAX),NBI*NBI)
CIJ=(100.*PP(IFROM))/NBI
GO TO ( 11,12,13,14,15),NUIT
write(*,*) 'demande de tableau doit ˆtre compris entre 1 et 5'
return
11 ILIGNE(JJ)=PP(IFROM)
GO TO 30
12 ILIGNE(JJ)=CIJ+0.5
GO TO 30
13 ILIGNE(JJ)= WIJ+0.5
GO TO 30
14 ILIGNE(JJ)=100.49-div(100.*CIJ,WIJ )
goto 30
15 CONTINUE
c case ++
iligne(jj)=min-pp(ifrom)
goto 30
30 IF((.NOT. IAIT(JCO) .OR. .NOT. IAIT(JLI) ).AND. MUIT .GT.10)
1 ILIGNE(JJ)=0
33 CONTINUE
IF(NBNB .GT.0)
1 write(0,50) nmi(JLI),(ILIGNE(JJ),JJ=1,NBNB)
C IMPRIMERN LIGNES NON VIDES SEULEMENT 8 JUILLET 86
50 FORMAT('0',I3,':',25I5)
3 CONTINUE
2 write(0, 9) (nmi(JJ),JJ=JCOG,JCOE)
1 CONTINUE
write(0, 4 )
4 FORMAT('1')
RETURN
END