module mod_scriptol
contains


!****************************************************************
SUBROUTINE scriptol (OAP,M,N,MD,ND,c,iii,tipo,occup)
IMPLICIT REAL*8(A-H,O-Z)
character*8 c(md)
character*80 cc
character(*) tipo(n)
DIMENSION OAP(MD,ND),iii(n),occup(n)
dimension aa(8)
nnn=8
seuil=1.d-6
seuil=0.2
NN=N/nnn
IF(NN.EQ.0) GOTO 85
DO KK=1,NN
   N1=nnn*(KK-1)+1
   N2=nnn*KK
   l=maxval(len_trim(tipo(n1:n2)))
   IF(N2.LT.N1) RETURN
   WRITE(6,*) ' '
   WRITE(6,1024) (iii(i),I=N1,N2)
   write(6,1026) (occup(i),I=N1,N2)
   if(l>0)write(6,1027) (tipo(i)(1:2),I=N1,N2)
   if(l>2)write(6,1027) (tipo(i)(3:8),I=N1,N2)
   if(l>8)write(6,1027) (tipo(i)(9:14),I=N1,N2)
   if(l>14)write(6,1027) (tipo(i)(15:18),I=N1,N2)
   WRITE(6,*) ' '
   DO JJ=n1,n2
      aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
   enddo
   DO JJ=1,M
      if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
         cc=' '
         do kkk=n1,n2
            cc((kkk-n1)*8+1:(kkk-n1+1)*8)='   . . .'
            if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
               write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
               oap(jj,kkk)
            endif
         enddo
         write(6,1028) jj,c(jj),trim(cc)
      endif
   enddo
enddo
WRITE(6,*) ' '
85    N1=nnn*NN+1
N2=N
l=maxval(len_trim(tipo(n1:n2)))
IF(N2.LT.N1) RETURN
WRITE(6,*) ' '
WRITE(6,1024) (iii(i),I=N1,N2)
write(6,1026) (occup(i),I=N1,N2)
if(l>0)write(6,1027) (tipo(i)(1:2),I=N1,N2)
if(l>2)write(6,1027) (tipo(i)(3:8),I=N1,N2)
if(l>8)write(6,1027) (tipo(i)(9:14),I=N1,N2)
if(l>14)write(6,1027) (tipo(i)(15:18),I=N1,N2)
WRITE(6,*) ' '
cc=' '
DO JJ=n1,n2
   aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
enddo
DO JJ=1,M
   if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
      cc=' '
      do kkk=n1,n2
         cc((kkk-n1)*8+1:(kkk-n1+1)*8)=' . . . .'
         if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
            write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
            oap(jj,kkk)
         endif
      enddo
      write(6,1028) jj,c(jj),trim(cc)
   endif
enddo
WRITE(6,*) ' '
1024  FORMAT(14X,8(3X,I5))
1026  FORMAT(14X,8(f8.4))
1027  FORMAT(14X,8(2X,a6))
1028  FORMAT(1x,i3,1x,a8,1x,a)
RETURN
END SUBROUTINE
!****************************************************************
 SUBROUTINE scriptol2 (OAP,M,N,MD,ND,c,iii,tipo,occup,file)
IMPLICIT REAL*8(A-H,O-Z)
character*10 c(md)
character*80 cc
character(*) tipo(n)
DIMENSION OAP(MD,ND),iii(n),occup(n)
dimension aa(8)
integer,optional :: file
if(present(file)) then
   ifile=file
else
   ifile=6
endif
nnn=8
seuil=1.d-6
seuil=0.2
NN=N/nnn
IF(NN.EQ.0) GOTO 85
DO KK=1,NN
   N1=nnn*(KK-1)+1
   N2=nnn*KK
   !print*,'n1,n2',n1,n2,tipo
   IF(N2.LT.N1) RETURN
   write(ifile,*) ' '
   write(ifile,1024) (iii(i),I=N1,N2)
   write(ifile,1026) (occup(i),I=N1,N2)
   write(ifile,1027) (tipo(i)(1:2),I=N1,N2)
   write(ifile,1027) (tipo(i)(3:8),I=N1,N2)
   write(ifile,1027) (tipo(i)(9:14),I=N1,N2)
   write(ifile,1027) (tipo(i)(15:20),I=N1,N2)
   write(ifile,*) ' '
   DO JJ=n1,n2
      aa(jj-n1+1)=0.d0
      aa(jj-n1+1)=maxval(oap(:,jj))
      aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
   enddo
   DO JJ=1,M
      if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
         cc=' '
         do kkk=n1,n2
            cc((kkk-n1)*8+1:(kkk-n1+1)*8)='   . . .'
            if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
               write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
               oap(jj,kkk)
            endif
         enddo
         write(ifile,1028) jj,c(jj),trim(cc)
      endif
   enddo
enddo
write(ifile,*) ' '
85    N1=nnn*NN+1
N2=N
IF(N2.LT.N1) RETURN
write(ifile,*) ' '
write(ifile,1024) (iii(i),I=N1,N2)
write(ifile,1026) (occup(i),I=N1,N2)
write(ifile,1027) (tipo(i)(1:2),I=N1,N2)
write(ifile,1027) (tipo(i)(3:8),I=N1,N2)
write(ifile,1027) (tipo(i)(9:14),I=N1,N2)
write(ifile,1027) (tipo(i)(15:20),I=N1,N2)
write(ifile,*) ' '
cc=' '
DO JJ=n1,n2
   aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
enddo
DO JJ=1,M
   if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
      cc=' '
      do kkk=n1,n2
         cc((kkk-n1)*8+1:(kkk-n1+1)*8)=' . . . .'
         if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
            write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
            oap(jj,kkk)
         endif
      enddo
      write(ifile,1028) jj,c(jj),trim(cc)
   endif
enddo
write(ifile,*) ' '
1024  FORMAT(16X,8(3X,I5))
1026  FORMAT(16X,8(f8.4))
1027  FORMAT(16X,8(2X,a6))
1028  FORMAT(1x,i3,1x,a10,1x,a)
RETURN
END SUBROUTINE
!****************************************************************
 SUBROUTINE scriptol3 (OAP,M,N,MD,ND,c,iii,tipo,occup,file)
IMPLICIT REAL*8(A-H,O-Z)
character*8 c(md)
character*80 cc
character(*) tipo(n)
DIMENSION OAP(MD,ND),iii(n),occup(n)
dimension aa(8)
integer,optional :: file
if(present(file)) then
   ifile=file
else
   ifile=6
endif
nnn=8
seuil=1.d-6
seuil=0.2
NN=N/nnn
IF(NN.EQ.0) GOTO 85
DO KK=1,NN
   N1=nnn*(KK-1)+1
   N2=nnn*KK
   IF(N2.LT.N1) RETURN
   write(ifile,*) ' '
   write(ifile,1024) (iii(i),I=N1,N2)
   write(ifile,1026) (occup(i),I=N1,N2)
   write(ifile,1027) (tipo(i)(1:2),I=N1,N2)
   write(ifile,1027) (tipo(i)(3:8),I=N1,N2)
   write(ifile,1027) (tipo(i)(9:14),I=N1,N2)
   write(ifile,1027) (tipo(i)(15:20),I=N1,N2)
   write(ifile,*) ' '
   DO JJ=n1,n2
      aa(jj-n1+1)=0.d0
      aa(jj-n1+1)=maxval(oap(:,jj))
      aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
   enddo
   DO JJ=1,M
      if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
         cc=' '
         do kkk=n1,n2
            cc((kkk-n1)*8+1:(kkk-n1+1)*8)='   . . .'
            if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
               write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
               oap(jj,kkk)
            endif
         enddo
         write(ifile,1028) jj,c(jj),trim(cc)
      endif
   enddo
enddo
write(ifile,*) ' '
85    N1=nnn*NN+1
N2=N
IF(N2.LT.N1) RETURN
write(ifile,*) ' '
write(ifile,1024) (iii(i),I=N1,N2)
write(ifile,1026) (occup(i),I=N1,N2)
write(ifile,1027) (tipo(i)(1:2),I=N1,N2)
write(ifile,1027) (tipo(i)(3:8),I=N1,N2)
write(ifile,1027) (tipo(i)(9:14),I=N1,N2)
write(ifile,1027) (tipo(i)(15:20),I=N1,N2)
write(ifile,*) ' '
cc=' '
DO JJ=n1,n2
   aa(jj-n1+1)=maxval(dabs(oap(:,jj)))
enddo
DO JJ=1,M
   if(any(dabs(oap(jj,n1:n2))/aa(1:8).gt.seuil)) then
      cc=' '
      do kkk=n1,n2
         cc((kkk-n1)*8+1:(kkk-n1+1)*8)=' . . . .'
         if(dabs(oap(jj,kkk))/aa(kkk-n1+1).gt.seuil) then
            write(cc((kkk-n1)*8+1:(kkk-n1+1)*8),'(f8.4)') &
            oap(jj,kkk)
         endif
      enddo
      write(ifile,1028) jj,c(jj),trim(cc)
   endif
enddo
WRITE(6,*) ' '
1024  FORMAT(16X,8(3X,I5))
1026  FORMAT(16X,8(f8.4))
1027  FORMAT(16X,8(2X,a6))
1028  FORMAT(1x,i3,1x,a10,1x,a)
RETURN
END SUBROUTINE
!****************************************************************
SUBROUTINE scriptolu (MAT,labelH,labelV,&
numeroH,numeroV,format,occup,ratio,longline)
implicit none
real(8) :: mat(:,:)

integer :: dim1,dim2,n1,n2,nbcol,lform

character(*),optional :: labelH(:),labelV(:)
integer,optional :: numeroH(:),numeroV(:),longline
character(*),optional :: format
real(8),optional :: ratio,occup(:)

character(100),allocatable :: labH(:),labV(:)
integer,allocatable :: numH(:),numV(:)
character(100) :: form,form_numeroH,form_labv,form_labH,form_occup

logical :: yw=.false.

!character*8 c(md)
character*135 cc
real(8),allocatable :: aa(:)
integer :: n,nbloc,llabv,ideb,ifin,kk,i,ll,longH,longV,l,j,jdeb,jfin,jj
real(8) :: seuil

dim1=size(mat,1)
dim2=size(mat,2)
allocate(aa(dim2))

if(present(format)) then
   form='('//format//')'
   print*,'format',format
   read(format(2:3),'(i2)',err=1) lform
   goto 2
   1 continue
   read(format(2:2),'(i1)') lform
   2 continue
else
   form='(f8.4)'
   lform=8
endif
if(yw) print*,'form,lform    ',trim(form),lform

if(present(labelV)) then
   llabv=maxval(len_trim(labelV))
else
   llabv=0
endif
if(yw)print*,'llabv',llabv

if(present(longline)) then
   n=longline
else
   n=80
endif

nbcol=(n-6-llabv)/lform
if(yw) print*,'nbcol',nbcol

if(present(ratio)) then
   seuil=ratio
else
   seuil=0.2d0
endif
if(yw) print*,'seuil',seuil
if(yw) print*,'n',n

nbloc=(dim2-1)/nbcol+1
if(yw) print*,'dim1',dim1
if(yw) print*,'dim2',dim2
if(yw) print*,'nbloc',nbloc

form_numeroH=' '
form_labH=' '
form_occup=' '
if(llabv==0) then
   write(form_numeroH,'(a,i2,a)') '(5X,99(2X,I',lform-2,'))'
   write(form_labH,'(a,i2,a)') '(5X,99(2X,A',lform-2,'))'
   write(form_occup,'(a)') '(5X,99'//trim(form)//')'
   form_labH(12:14)=adjustl(form_labH(12:14))
elseif(llabv>0) then
   write(form_numeroH,'(a,i2,a,i2,a)'),'(5X,',llabv+1,'X,99I',lform,')'
   write(form_labH,'(a,i2,a,i2,a)'),'(5X,',llabv+1,'X,99(2X,A',lform-2,'))'
   write(form_occup,'(a,i2,a)'),'(5X,',llabv+1,'X,99'//trim(form)//')'

endif
if(yw)print*,'form_numeroH  ',trim(form_numeroH)
if(yw)print*,'form_labH  ',trim(form_labH)

if(present(labelH)) then
   longH=0
   do i=1,dim2
      longH=max(longH,len_trim(labelH(i)))
   enddo
else
   longH=0
endif
if(yw)print*,'longH',longH

!==============================================
ifin=0
DO KK=1,nbloc
   ideb=ifin+1
   ifin=ifin+nbcol
   ifin=min(ifin,dim2)

   ! ecriture des numeros horizontaux
   print*,' '
   if(present(numeroH)) then
      print form_numeroH,(numeroH(i),i=ideb,ifin)
   else
      print form_numeroH,(i,i=ideb,ifin)
   endif
   print*,' '

   ! ecriture des occupations
   if(present(occup)) then
      print form_occup,(occup(i),i=ideb,ifin)
   endif
   print*,' '

   ! ecriture labelH
   if(present(labelH)) then
      l=maxval(len_trim(labelH(ideb:ifin)))
      !if(yw)print*,'l',l,(l-1)/(lform-2)
      jfin=0
      do j=1,(l-1)/(lform-2)+1
         jdeb=jfin+1
         jfin=jfin+lform-2
         jfin=min(jfin,l)
         write(6,form_labH) adjustr(labelH(ideb:ifin)(jdeb:jfin))
      enddo
      print*,' '
   endif

   !ecriture matrice

   ! aa(ll) = max elmt mat de la colonne ll
   aa=0.d0
   do ll=ideb,ifin
      do i=1,dim1
         aa(ll)=max(aa(ll),abs(mat(i,ll)))
      enddo
   enddo

   ! ecriture matrice
   do ll=1,dim1
      if(any(abs(mat(ll,ideb:ifin))/aa(ideb:ifin).gt.seuil)) then
         write(6,'(i4)',advance='no') ll
         if(present(labelV)) then
            write(6,'(1x,a,1x)',advance='no') trim(labelV(ll))
            do i=len_trim(labelV(ll))+1,llabV
               write(6,'(1X)',advance='no')
            enddo
         endif
         jfin=0
         cc=' '
         DO JJ=ideb,ifin
            jdeb=jfin+lform-4
            jfin=jfin+lform
            if(abs(mat(ll,jj))/aa(jj)>seuil) then
               write(cc(jfin-lform+1:jfin),form) mat(ll,jj)
            else
               cc(jdeb:jfin)='. . .'
            endif
         enddo
         write(6,'(a)') cc(1:jfin)
      endif
   enddo
enddo
RETURN
END SUBROUTINE
!****************************************************************
END MODULE
