#define ARDOCKLINK
c#define MPI
c#define QMPIFH
c#define MODIFIER "MODIFIER"

#define MAXN 2000 
#define MAXCH 10 
#define MAXF 80
#define MAXLAG 30 
#define MAXPAR 200 

#define IOUNIT 18 
#define KEEPUNIT 99 
#define TUTUNIT 98 
#define BUGLOG 91
#define BUGMAP 92
c   .    1    .    2    .    3    .    4    .    5    .    6    .    7        
c This version, v.2, is obtained by applying
c  ardock.0-2.patch to the original ardock.F
c  or
c  ardock.1-2.patch to the version, v.1, obtained by applying
c  ardock.0-1.patch to the original ardock.F
corrected2000.11.21 corrections are made by M.I.
c  4. bug in subroutines showc, showr and showi are removed.
c  3. minor bug related to the variable mAINT is removed. 
corrected2000.10.20 corrections are made by M.I.
c  two kind of bugs are fixed.
c  2.  correction of dall / rather serious one. This correction is
c      necessary to avoid possible dead-locks.  
c  1.  showm --> showm2  / not a serious bug.
corrected2000.01.21 corrections are made by M.I.
corrected2000.01.20 corrections are made by M.I.
corrected1999.12.14 corrections are made by M.I.
corrected1999.10.28 corrections are made by M.I.
c ARdock_package 
c Copyright_OML 1999 M. Ishiguro, H. Kato and H. Akaike 
c  The source code of this package can be obtained from ISMLIB 
c  (ftp://ftp.ism.ac.jp/pub/ISMLIB/) of the Institute of Statistical 
c  Mathematics without any charge.
c  On the conditions that terms of the OPEN MARKET LICENCE for software 
c  (version:OML-SW-E-1996, ftp://ftp.ism.ac.jp/pub/ISMLIB/OML) are observed  
c  and that the copyright holder nor the Institute of Statistical Mathematics 
c  take no responsibility on any result from the use, programs in the package 
c  can be used or modified freely. On the condition that this note is 
c  attached as it is, this package can be redistributed.
c  
c
c OPEN MARKET LICENSE for software ( version:OML-SW-E-1996)
c 
c 0. In the following ,  'Copyright_OML notice' means 'the copyright         '
c    notice with a statement saying that the said software is made 
c    public under this OPEN MARKET LICENSE for software'.                    '
c 1. On the condition that 'Copyright_OML notice' and attached 
c    statements are copied as they are ,  all or any portion of the 
c    said software can be copied or redistributed. 
c 2. Modification of the software is permitted ,  provided that 
c    the exact place of the modification ,  the date and the name 
c    of the modifier are shown conspicuously. 
c 3. It is forbidden to apply for a patent on the software which 
c    utilizes the said software.
c 4. The said software is distributed without any warranty. The 
c    copyright holder takes no responsibility for any damage caused 
c    by the use of the said software.
c 5. Any interactively controlled application made utilizing the 
c    said software has to show 'Copyright_OML notice' and attached 
c    statements conspicuously when it is started up.
c
c  The complete ARdock package is composed of this source file and
c  the monograph:
c    Ishiguro,M., Kato,H. and Akaike,H. (1999). 
c    Ardock, an Auto-Regressive model analyzer, Computer Science Monographs, 
c    No.30, The Institute of Statistical Mathematics, Tokyo.
c  
c  This monograph is designed to serve as the user manual of ARdock.
c In the monograph, mathematical formulas for model fitting and
c interpretation of the linear multivariate time series and system  are 
c collected. A model,  E-MARTS model is proposed for the purpose of
c system analysis.  Model fitting is performed by the  least
c squares method via Householder transformation and the numerical
c maximization of the log likelihood whose calculation is realized 
c by applying  the Kalman filtering technique.  
c All the necessary computational routines are contained in this file. 
c  This package is so designed that it can readily be used by
c the users interested in analyzing their own  data, and also  serves as 
c a bank of subroutines for the general use by statistical model builders.  
c  The equation numbers or section numbers reffered in the routines 
c in this file is of the Computer Science Monograph(CSM) No.30. CSM No.30  
c is distributed from ISMLIB of the Institute of Statistical Mathematics
c (http://www.ism.ac.jp/software/ismlib/soft.e.html).
c
contents  subpackages
contents  1. main                 subpackage
contents    1.1   main                
contents    1.2   getar               
contents    1.3   getdata             
contents    1.4   fitar
contents    1.5   easydall            
contents    1.6   gui0                
contents  2. ardock               subpackage
contents    2.1   ardock              
contents    2.2   arsimu              
contents    2.3   maskedar            
contents    2.4   autodock            
contents    2.5   subaic              
contents    2.6   pbpgraph            
contents    2.7   pwgraph             
contents    2.8   cohgraph            
contents    2.9   pwfile              
contents    2.10  gui1                
contents    2.11  gui2                
contents    2.12  gui3                
contents    2.13  click1              
contents    2.14  click2              
contents    2.15  subwin1             
contents  3. datard               subpackage
contents    3.1   datard              
contents    3.2   rparam              
contents    3.3   fparam              
contents    3.4   gparam              
contents    3.5   jdate               
contents    3.6   cpar                
contents    3.7   ipar                
contents    3.8   rpar                
contents    3.9   clab                
contents    3.10  cset                
contents    3.11  iset                
contents    3.12  rset                
contents  4. arfi                 subpackage
contents    4.1   arfit               
contents    4.2   arfitw              
contents    4.3   marfit              
contents    4.4   sarfit              
contents    4.5   build               
contents    4.6   indexset            
contents    4.7   sssolver            
contents    4.8   click3              
contents    4.9   subwin2             
contents    4.10  arorder              
contents    4.11  arfile              
contents    4.12  arfilw             
contents  5. marts                subpackage
contents    5.1   marts               
contents    5.2   martsw              
contents    5.3   martspar            
contents    5.4   gmarts              
contents    5.5   gmartw             
contents    5.6   tarmodel            
contents    5.7   remtsbx             
contents    5.8   subabh              
contents    5.9   subqrs              
contents  6. ready                subpackage
contents    6.1   ready               
contents    6.2   maskrs              
contents  7. pwspx                subpackage
contents    7.1   pwspx               
contents    7.2   subnosx             
contents    7.3   subcoh              
contents  8. pwevol               subpackage
contents    8.1   pwevol              
contents    8.2   pwprof              
contents    8.3   llset               
contents  9. lgraph               subpackage
contents    9.1   lgraph              
contents    9.2   gfile               
contents  10. hushld               subpackage
contents    10.1  hushld              
contents    10.2  solve               
contents    10.3  cxhushld            
contents    10.4  cxsolve             
contents    10.5  fouger              
contents    10.6  fouge1             
contents    10.7  posmat              
contents    10.8  invmat              
contents    10.9  rn01                
contents    10.10 rnor                
contents  11. dall                 subpackage
contents    11.1  dall                
contents    11.2  bill                
contents    11.3  numdif              
contents    11.4  innerp              
contents    11.5  lftint              
contents    11.6  eval                
contents  12. kalman               subpackage
contents    12.1  kalman              
contents    12.2  kalmaw             
contents    12.3  both                
contents    12.4  left                
contents    12.5  right               
contents    12.6  clr                 
contents    12.7  fmatrix
contents  13. sadjust              subpackage
contents    13.1  sadjust             
contents    13.2  sadjuw            
contents    13.3  subsea              
contents    13.4  setd                
contents    13.5  setdc                
contents    13.6  setx                
contents    13.7  decode              
contents    13.8  exhsld              
contents    13.9  exsolve             
contents    13.10 init                
contents  14. mpiinit              subpackage
contents    14.1  mpiinit             
contents    14.2  mpion               
contents    14.3  mpioff              
contents    14.4  mpison             
contents    14.5  mpisoff            
contents    14.6  mpisres            
contents    14.7  mpistop             
contents  15. keysave              subpackage
contents    15.1  keysave             
contents    15.2  keympi              
contents    15.3  markinp             
contents    15.4  jfrex               
contents  16. areachk              subpackage                                  
contents    16.1  areachk             
contents    16.2  iw                  
contents    16.3  nw                  
contents  17. selfcom              subpackage
contents    17.1  selfcom             
contents    17.2  selfend             
contents    17.3  showc               
contents    17.4  showi               
contents    17.5  showr               
contents    17.6  showw               
contents    17.7  showm               
contents    17.8  showm2               
contents    17.9  showm3               
contents    17.10 them                
contents    17.11 oml                 
contents  18. bug                  subpackage
contents    18.1  bug                 
contents    18.2  sbuggle             
contents    18.3  bugnet                
contents    18.4  bughtrap            
contents    18.5  bugvtrap            
contents    18.6  debug               
contents    18.7  bugp                

#ifdef AUTHOR 
contents  19. mswitch              subpackage
contents    19.1  mswitch             
contents    19.2  xmodel              
contents    19.3  arfitq       
contents    19.4  simdat              
contents    19.5  design              
contents    19.6  selflist            
contents  20. structur            subpackage
contents    20.1  structur           
contents    20.2  findname            
contents    20.3  check               
contents    20.4  sorta               
contents    20.5  sortb               
contents  21. moshiur-pack         subpackage
contents    21.1  moshiur           
contents    21.2  gmoshiur            
contents  whymper              subpackage
contents      why23               
contents      why34               
contents      why45               
contents      why56               
contents      whymper             
contents      wrhist              
contents      set                 
contents  mitex                subpackage
contents      aarry               
contents      mitex               
contents      sarry               
contents      smat                
contents      snum                
contents      stext               
contents  mpi_init             subpackage
contents      mpi_abort           
contents      mpi_allgather       
contents      mpi_allgatherv      
contents      mpi_barrier         
contents      mpi_bcast           
contents      mpi_comm_rank       
contents      mpi_comm_size       
contents      mpi_finalize 
contents      mpi_init            
contents      mpi_reduce          

CPACK-member mpi_init        
cpack-member mpi_bcast        
cpack-member mpi_comm_rank       
cpack-member mpi_comm_size       
cpack-member mpi_abort 
cpack-member mpi_allgatherv      
cpack-member mpi_allgather       
cpack-member mpi_reduce       
cpack-member mpi_barrier  
cpack-member mpi_finalize 
CPACK-member mpiinit 
cpack-member mpistop  
cpack-member mpion               
cpack-member mpison             
cpack-member mpioff              
cpack-member mpisres            
cpack-member mpisoff            
CPACK-member selfcom 
cpack-member them 
cpack-member selfend 
cpack-member selflist 
cpack-member showr  
cpack-member showi  
cpack-member showc  
cpack-member showw  
cpack-member showm  
cpack-member showm2  
cpack-member showm3  
CPACK-member areachk 
cpack-member iw                  
cpack-member nw                  
CPACK-member keysave 
cpack-member keympi 
cpack-member jfrex               
CPACK-member lgraph 
cpack-member gfile 
CPACK-member hushld 
cpack-member solve 
cpack-member cxhushld  
cpack-member cxsolve 
cpack-member posmat 
cpack-member invmat  
cpack-member fouger   
cpack-member fouge1  
cpack-member rn01                
cpack-member rnor                
CPACK-member mitex
cpack-member snum 
cpack-member smat  
cpack-member stext  
cpack-member sarry 
cpack-member aarry 
CPACK-member ready 
cpack-member maskrs 
CPACK-member dall 
cpack-member lftint  
CPACK-member bug
cpack-member sbuggle  
cpack-member bugnet  
cpack-member bugp 
cpack-member bugvtrap 
cpack-member bughtrap 
CPACK-member kalman 
CPACK-member sadjust 
CPACK-member arfit  
cpack-member arfile  
CPACK-member datard 
cpack-member rparam
cpack-member iset  
cpack-member cset 
cpack-member rset 
cpack-member jdate 
cpack-member fparam 
cpack-member gparam 
cpack-member ipar                
cpack-member rpar                
CPACK-member marts 
cpack-member gmarts 
cpack-member martspar 
CPACK-member mswitch 
cpack-member xmodel  
CPACK-member pwspx 
CPACK-member pwevol  
CPACK-member ardock  
CPACK-member whymper 
cpack-member why23 
cpack-member why34 
cpack-member why45 
cpack-member why56 
cpack-member wrhist  
CPACK-member structur 
#endif

contents  1. main                 subpackage
checkpoint: lano =    01/129/sp2.@990422.@152623 ........
contents    1.1   main                
      program main 
       implicit real*8 ( a-h , o-z )      
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
#endif  
       character*1  cmd , ckey 
       character*70 datafile 
#ifdef ARDOCKLINK
       dimension var ( MAXCH  *  MAXCH ) ,
     * ar ( MAXCH  *  MAXCH  *  MAXLAG ) 
#else
       dimension var ( MAXCH  *  MAXCH ) , 
     * ar ( MAXCH  *  MAXCH  *  MAXLAG ) , poly ( MAXCH * 5)
#endif
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
       common /cmitexn/ mt
#endif 
       dimension data ( MAXN  *  MAXCH ) , kbuf (2)
c      ........................................................
c      ARdock_main 
c      Copyright_OML 1999 M. Ishiguro and H. Kato 
c       The source code of this program, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this program 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this program can be redistributed.

       call mpiinit 
#ifdef MODIFIER
       call them 
#endif
       call bug (1,0,0,0,'start',0,0.d0,message)
       call bug (1,0,0,0,'tutorial',511,1999.d0,message)
       if( message .eq. 123 ) write(6,*) 'message is received'
       call sbuggle (jewel)
       if( jewel .eq. 456 ) write(6,*) 'message can be smuggled in'
       do 1 j = 1,10
          call bug (2,j,7,8,'peekaboo',j,0.d0, message )
          call bug (1,j,10,10,'hello',0,0.d0,message)
    1  continue 
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          kbuf (1)  =  nw ('}' , nw0)
          kbuf (2)  =  iw ('}' , iw0)
#ifdef    MPI 
          call mpi_reduce ( kbuf , kbuf , 2 , MPI_INTEGER , 
     *    MPI_MAX , 0 , MPI_COMM_WORLD , ierr )
          call mpi_finalize ( ierr )
#endif 
          if( myid .eq. 0) then 
             write(6,*) 'wK area usage :' ,  kbuf (1)
             write(6,*) 'wK area limit :' ,  nw ('<limit>' , 0)
             write(6,*) 'iWK area usage:' ,  kbuf (2)
             write(6,*) 'iWK area limit:' ,  iw ('<limit>' , 0)
          end if 
          call bug (1,0,0,0,'finish', 0 , ar (1) , message )
       end if
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('ARdock_main', io , stio )
          call showm3 ('I',
     i    'User''s manual:',
     i    ' Ishiguro,M., Kato,H. and Akaike,H. (1999).', 
     i    ' Ardock, an Auto-Regressive model analyzer, ')
          call showm2 ('I',
     i    ' Computer Science Monographs, No.30, ',
     i    ' The Institute of Statistical Mathematics, Tokyo.')
          call showm ('I','Bon voyage!')
          call showm ('O','Welcome home!')                    
          call selfend ( myself , io , inisub )
#ifdef    AUTHOR 
          if( mAINT .eq. 1 ) then
             if( io .eq. 'O')  call selflist (' ' , 'list')
          end if
#endif
       end if 
#endif
       if( io .ne. 'O') then
catch- call nw
          nw0  =  nw ('{' , NWORK )
          iw0  =  iw ('{' , IWORK )
          goto 9200
       end if
c      ------
       stop 
c      ====       
 9200  continue 
       io = 'O' 
       call keysave ('@', '@KEEP' , 0 , ckey , rbuf , kbuf )
#ifdef AUTHOR 
       if( mAINT .eq. 1 ) then
          call mitex ('sp2.@990422.@152623') 
       else 
          mt = 8 
       end if 
       call stext ('name' ,  - 1 , 'ARdock')
       nMITEX = 0  
#endif 
#ifdef ARDOCKLINK
       call gui0 (
     o cmd )
       if( cmd .eq. 'm') then 
          call getar (
     o    var , ar , kch , lag , ndata )
       else 
          call getdata (
     i    cmd , 
     o    datafile , data , rlim , kch , ndata )
          call bug (1,0,0,0,'fitar', ndata , 
     *    data ( ndata * kch ), message )
          call fitar (
     i    datafile , data , rlim , kch , ndata , 
     o    var , ar , lag )
       end if 
       call bug (1,0,0,0,'ardock', lag , var (1), message )
       call ardock (
     i var , ar , kch , lag , ndata )
#else
          call getdata (
     i    cmd , 
     o    datafile , data , rlim , kch , ndata )
          lagmax = min ( MAXLAG , 10 )
          mean = 1 
          call arfit (
     i    data , ndata , kch , lagmax , mean , 
     o    aicmin , var , ar , poly ,
     o    lag , wk ( nw ('indexm', kch * kch )))
#endif
       goto 9100 
      end                                                    

checkpoint:  lano =    02/129/sp2.@990422.@152623 ........
contents    1.2   getar               
c reusable
      subroutine getar (
     o Var , Ar , Kch , Lag , Ndata )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Var (100) , Ar (3000)
       character*70 modfile 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ..........................................................
c      getar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          if( Ndata .eq. 0) Ndata = 100 
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('getar', io , stio )                  
          call showm2 ('I',
     i    ' Reads AR model file to recover AR model parameters.',
     i    ' See Section 5.4.2 of CSM for the proper form of the file.')
          call showr ('O','Var' ,  Var ,    Kch , Kch , Kch )     
          call showr ('O','Ar' ,   Ar ,     Kch , Kch , Kch )
          call showi ('O','Kch' ,  Kch ,    1 , 1 , 1)
          call showi ('O','Lag' ,  Lag ,    1 , 1 , 1)    
          call showi ('O','Ndata' ,Ndata ,  1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      -------------------------- 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .eq. 0) then 
           call keysave ('c','AR file:' , 0 , modfile , rx , ldummy )
           write(6,*) modfile 
           open ( IOUNIT , file = modfile )      
           call arfile (
     i     '-->' , IOUNIT , 
     O     Var , Ar , Kch , Lag )
           close ( IOUNIT )
           Ndata = ipar ('length')
catch-     call ipar 
       end if 
#ifdef MPI 
       call mpi_bcast( Ndata , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast( Lag , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast( Kch , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD , 
     * ierr )
       call mpi_bcast( Var , Kch  * Kch , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
       call mpi_bcast( Ar , Kch * Kch * Lag , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
#ifdef AUTHOR  
       call snum ('modelfile' ,  - 1 , IOUNIT * 1.d0 , '( f10.0)') 
#endif 
       goto 9100 
      end 

checkpoint:   lano =    03/129/sp2.@990422.@152623 ........
contents    1.3   getdata             
c reusable
      subroutine getdata (
     i Cmd , 
     o Datafile , Data , Rlim , Kch , Ndata )
       implicit real*8 ( a-h , o-z )       
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
#ifdef ARDOCKLINK
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
#endif
       dimension Data ( MAXN * MAXCH ) 
       dimension kbuf ( MAXCH ) , rbuf ( MAXCH )
       character*1 Cmd  
       character*70 Datafile 
       character*1  io 
#ifdef MODIFIER
       character*1 stio , ckey
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ........................................................
c      getdata
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          call areachk (
     i    'getdata' , 'MAXN' , MAXN , Ndata , 1 ,
     o    ierr )
          call areachk (
     i    'getdata' , 'MAXCH' , MAXCH , Kch , 1 ,
     o    ierr )
       end if
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('getdata', io , stio )                    
          call showm2 ('I',
     i    ' Reads time series data file.',
     i    ' See section 5.4.1 of CSM for the proper form of the file.')
          call showc ('I','Cmd' ,     Cmd,        1 , 1 , 1)       
          call showc ('O','Datafile', Datafile , 1 , 1 , 1)
          call showr ('O','Data' ,    Data,      Ndata , Ndata , Kch )
          call showr ('O','Rlim' ,    Rlim ,     1 , 1 , 1)      
          call showi ('O','Kch' ,     Kch ,      1 , 1 , 1)
          call showi ('O','Ndata' ,   Ndata ,    1 , 1 , 1)      
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      -------------------------- 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call bug (1,0,0,0,'qq1',0,0.d0,message)
       Datafile = 'generated.dat'
       if( Cmd .ne. 'g') then 
          if( myid .eq. 0) then 
       call bug (1,0,0,0,'qq2',0,0.d0,message)
             call keysave ('c','data file:' , 
     *       0 , Datafile , rbuf , kbuf )
             open ( IOUNIT , file = Datafile )
             call datard (
     i       IOUNIT , 
     o       Data , Ndata , Kch )
             close ( IOUNIT ) 
#ifdef       AUTHOR 
             call smat ('data' ,  - 1 , Data , Ndata , Kch , 
     *       '(4d20.12)' , Ndata , Kch )
#endif 
          end if 
          call rparam (
     i    11 , 'distribute' , 0 , ierr )
#ifdef AUTHOR 
       else 
          if( myid .eq. 0 .and. mAINT .eq. 1) then 
             call keysave ('i','simulation parameters Ndata , Kch:' , 
     *       2 , ckey , rbuf , kbuf )
             Ndata  =  kbuf (1)
             Kch  =  kbuf (2)
             call simdat (
     i       Ndata , Kch , 
     o       Data )
             call rparam (
     i       11 , 'init' , 0 , ierr )
             call iset ('length' , Ndata )
             call iset ('channel' , Kch )
             call cset ('title' , 'simulation data')
             call cset ('unit' , 'year')
             call rset ('sampling' , 0.25d0)
          end if 
#endif 
       end if 
#ifdef MPI 
       call mpi_bcast ( Ndata , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast ( Kch , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast ( Data , Ndata * Kch , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
catch- call rpar 
       if( myid .eq. 0) Rlim = rpar ('missing')
#ifdef MPI 
       call mpi_bcast ( period , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast ( Rlim , 1 , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
#ifdef ARDOCKLINK
       if( myid .eq. 0) then 
          ncrip  =  Ndata 
          if( ncrip .gt. 5) ncrip  =  5 
          write(6 , '( i4 , '' - dimensional data of length'' , i4)')
     *    Kch ,  Ndata 
          do 98 j = 1 , Kch 
             write(6 , '(A , 5d12.3 , '' ....'')')
     *       cHLAB ( j ) , ( Data (( j - 1) * Ndata + i ) ,
     *       i = 1 , ncrip )
   98     continue 
       end if 
#endif
       goto 9100 
      end 

#ifdef ARDOCKLINK
checkpoint:    lano =    04/129/sp2.@990422.@152623 ........
contents    1.4   fitar
c ardock-specific               
      subroutine fitar (
     i Datafile , Data0 , Rlim0 , Kch0 , Ndata0 , 
     o Var , Ar , Lag )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH ) 
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Var ( MAXCH * MAXCH ) , Ar ( MAXCH * MAXCH * MAXLAG) ,
     * Data0 ( MAXN * MAXCH ), el ( MAXN ) 
       character*1 ckey , akey , cx 
       character*70 modfile , xmodfile  
       character*60 wkfile , xwkfile , pfile 
       character*70 Datafile 
       dimension par ( MAXPAR ) , part ( MAXCH )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       external gmarts , marts   
#ifdef MOSHIUR 
       external moshiur , gmoshiur   
#endif 
#ifdef AUTHOR 
       external mswitch , xmodel   
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ........................................................
c      fitar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('fitar', io , stio )                  
          call showm3 ('I',
     i    ' Assembles and fits an E-MARTS model to get the AR',
     i    ' component parameters.', 
     i    ' See Section 2.6 of CSM.')
          call showc ('I','Datafile', Datafile ,1 , 1 , 1)
          call showr ('I','Data0' , Data0 , Ndata0 , Ndata0 , Kch0)
          call showr ('I','Rlim0' ,   Rlim0 ,   1 , 1 , 1)    
          call showi ('I','Kch0' ,    Kch0 ,    1 , 1 , 1)
          call showi ('I','Ndata0' ,  Ndata0 ,  1 , 1 , 1)    
          call showr ('O','Var' ,     Var ,     Kch0 , Kch0 , Kch0)
          call showr ('O','Ar' ,      Ar ,      Kch0 , Kch0 , Kch0)
          call showi ('O','Lag' ,     Lag ,     1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call maskrs (
     i Kch0 , 
     o indexm )
       rLIM = Rlim0 
       kCH = Kch0 
       nDATA = Ndata0 
       do 9201 i = 1 , kCH  *  nDATA 
          dATA ( i ) = Data0 ( i )
 9201  continue 
       call keympi ('i','Initial data length:' , 
     * 1 , akey , rx , lAGMAX )
       if( myid .eq. 0) then 
          wkfile = Datafile 
          jp = 0 
          do 199 j = 1 , 70 
             if( wkfile ( j:j ) .eq. '.') jp = j 
             if( wkfile ( j:j ) .eq. ' ') then 
                if( jp .eq. 0) then 
                   wkfile ( j:j ) = '.'
                   jp = j 
                end if 
                goto 197 
c               ======= 
             end if 
  199     continue 
  197     continue 
          xwkfile = wkfile (1:jp ) // 'WK       '
          wkfile = xwkfile 
          write(6,'(''E-MARTS file = '',A)') wkfile 
          modfile = Datafile 
          jp = 0 
          do 99 j = 1 , 70 
             if( modfile ( j:j ) .eq. '.') jp = j 
             if( modfile ( j:j ) .eq. ' ') then 
                if( jp .eq. 0) then 
                   modfile ( j:j ) = '.'
                   jp = j 
                end if 
                goto 97 
c                ======= 
             end if 
   99     continue 
   97     continue 
          xmodfile = modfile (1:jp ) // 'AR       '
          modfile = xmodfile 
       end if 
       nSYS  =  kCH  
       iNITMART = 1
       do 9202 i = 1 , kCH  
          lISTPE ( i ) = 1 
 9202  continue 
#ifdef AUTHOR 
       if( mAINT .eq. 1 ) 
     * call keympi ('c','whymper?' , 0 , akey , rx , ix )
       if( mAINT .eq. 0 .or. akey .eq. 'n') then 
#endif
          ndall = 0 
          el (1) = 0.d0 
          call keympi ('c','new model?', 0 , ckey , rx , ix )  
          if( ckey .ne. 'y') then
             if( myid .eq. 0) then 
                call keysave ('c','E-MARTS file:' , 
     *          0 , pfile , rbuf , kbuf )
                open ( IOUNIT , file = pfile )
                call ready ( IOUNIT )
                read(IOUNIT, * ) ndall , el (1)  
                read(IOUNIT, * ) mEAN , nSYS , lAGOPT , lAGMAX  
                read(IOUNIT, * ) 
     *          ( iNDEXM ( i ), i = 1, MAXCH * MAXCH ) 
                read(IOUNIT, * ) ( lISTPE ( i ), i = 1, MAXCH ) 
                read(IOUNIT, * ) npar 
                read(IOUNIT, * ) ( par ( j ), j =1, npar )
                close (IOUNIT)
             end if 
#ifdef       MPI 
             call mpi_bcast ( ndall , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( el , 1 , MPI_DOUBLE_PRECISION , 
     *       0 , MPI_COMM_WORLD , ierr )
             call mpi_bcast ( mEAN , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( nSYS , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( lAGOPT , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( lAGMAX , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( iNDEXM , MAXCH * MAXCH ,
     *       MPI_INTEGER , 0 , MPI_COMM_WORLD , ierr )
             call mpi_bcast ( lISTPE , MAXCH , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( npar , 1 , MPI_INTEGER , 0 , 
     *       MPI_COMM_WORLD , ierr )
             call mpi_bcast ( par , npar , MPI_DOUBLE_PRECISION , 
     *       0 , MPI_COMM_WORLD , ierr )
#endif 
             goto 1300
          end if  
#ifdef MOSHIUR
          call gmoshiur ( par , npar )
#else
          call gmarts ( par , npar )
#endif
 1300     continue 
          call bug (1,0,0,0,'easydall', npar , par ( npar ), message )
          if( myid .eq. 0) then 
             write(6,'(''WK file = '',A)') wkfile 
             open (IOUNIT , file = wkfile ) 
             write(IOUNIT, * ) wkfile 
             write(IOUNIT, * ) 'E-MARTS model parameter'
             write(IOUNIT, * ) 'el =', el (1)   
             write(IOUNIT,'(A)') 'DATASTARTINGLINE'
             write(IOUNIT, * ) ndall , el (1)  
             write(IOUNIT, * ) mEAN , nSYS , lAGOPT , LAGMAX  
             write(IOUNIT, * ) 
     *       ( iNDEXM ( i ), i = 1, MAXCH * MAXCH ) 
             write(IOUNIT, * ) ( lISTPE ( i ), i = 1, MAXCH ) 
             write(IOUNIT, * ) npar 
             write(IOUNIT, * ) ( par ( j ), j = 1, npar )
             close (IOUNIT)
          end if 
          call keympi ('c','DALL?',0, cx , rx , ix )
          if( cx .eq. 'y') then 
             call areachk (
     i       'fitar' , 'maxpar' , MAXPAR , npar , 1 ,
     o       ierr )
#ifdef MOSHIUR
             call easydall (
     i       moshiur , npar , 
     a       par , 
     o       el )
#else
             call easydall (
     i       marts , npar , 
     a       par , 
     o       el )
#endif
             ndall = ndall + 1 
             goto 1300 
          end if 
#ifdef AUTHOR
       end if
       if( mAINT .eq. 1 ) then
          if( akey .eq. 'y') then 
             call why23
             call why34 
             call why45 
             call why56 
             call whymper ( gmarts , marts , par , npar , el , igw )
          end if
          if( akey .eq. 'x') then 
             call why23
             call why34 
             call why45 
             call why56 
             call whymper ( mswitch , xmodel , par , npar , el , igw )
             call xmodel ( par , npar , el , lel )
          end if
       end if
#endif
       call martspar (
     i '-->' , 'var' , 0 ,
     i Par , npar , kCH , kCH ,  
     o Var , Ival )  
       call martspar (
     i '-->' , 'ar' , 0 , 
     i Par , npar , kCH , kCH ,  
     o Ar , lAGOPT )  
       if( myid .eq. 0) then 
          call cset ('arfit' , 'e-marts')
          call martspar (
     i    '-->' , 'model' , 0 ,
     i    Par , Npar , kCH , kCH ,  
     o    part , Ival )  
          if( ndall .gt. 0 ) then
             aic  =   - 2.d0 *  el (1) + 2.d0 * npar 
             write(6,'('' AIC = '',f10.2)') aic  
          else
corrected2000.11.21 one line added by M.I.
             aic = 99999.d0 
             iNITMART = 1
             call marts ( par , npar , el , lel )
             if( lel .gt. 0 ) then
                write(6,'('' log likelihood = '',f10.2)') el (1)
             else 
                write(6,'('' log likelihood can not be evaluated.'')')
             end if
          end if
          write(6,'('' npar = '',i4)') npar 
          write(6,'('' DALL call count = '',i4)') ndall  
          call rset ('aic' , aic )
          call iset ('nparam' , npar )
          write(6,'(''AR file = '',A)') modfile 
          open (IOUNIT , file = modfile )
          call arfile (
     i    '<--' , IOUNIT , 
     O    Var , Ar , kCH , lAGOPT )
          close ( IOUNIT )
       end if 
       Lag = lAGOPT 
       call bug (1,0,0,0,'e-marts', lel , el (1), message )
       goto 9100 
      end 
#endif


checkpoint:     lano =    05/129/sp2.@990422.@152623 ........
contents    1.5   easydall            
c reusable
      subroutine easydall (
     i Model , Ip , 
     a A , 
     o Val )
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       parameter ( nlim = 100)
       dimension A ( Ip ) , step ( nlim ) , g ( nlim ) 
       dimension el ( MAXN )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       external Model 
c      ........................................................
c      easydall 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('easydall', io , stio )
          call showm3 ('I',
     i    ' Reserves work area and calls subroutins dall for the',
     i    ' log likelihood maximization.',
     i    ' See Appendix D of CSM.')
          call showi ('I','Ip' ,  Ip ,     1 , 1 , 1)
          call showr ('A','A'   , A ,      1 , 1 , Ip )
          call showr ('O','Val' ,   Val ,    1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call areachk (
     i 'easydall' , 'nlim' , nlim , Ip , 0 ,
     o ierr )
       if( ierr .eq. 1 ) goto 9100
       do 1 i = 1 , Ip 
          step ( i ) = 0.01d0 
    1  continue 
       limit = 0 
       lpsw = 3 
       call dall ( Model , A , Ip , el , g , 
     * wk ( nw ('vd' , Ip  * ( Ip  + 5))) , 
     * endc , step , limit , lpsw )
       Val = el (1)
       goto 9100 
      end         

#ifdef ARDOCKLINK
checkpoint:      lano =    06/129/sp2.@990422.@152623 ........
contents    1.6   gui0                
c ardock-specific
      subroutine gui0 (
     o Cmd )
       implicit real*8 ( a-h , o-z )       
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension rbuf ( MAXCH )
       character*1 Cmd  
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      .........................................................
c      gui0 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9       
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
           call selfcom ('gui0', io , stio )                    
corrected2000.10.20  1 line correction made by M.I.
c          call showm ('I',
          call showm2 ('I',
     i    ' Prompts user for the choice between data and model.',
     i    ' See Section 6.2 of CSM.')
           call showc ('O','Cmd' ,   Cmd ,   1 , 1 , 1)       
           call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9200  continue 
       io = 'O'
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
       if( mAINT .eq. 1 ) then 
          call keympi ('c','d)ata, m)odel or g)enerated data ?' , 
     *    0 , Cmd , rbuf , ibuf ) 
       else 
#endif
          call keympi ('c','d)ata or m)odel?' , 0 , Cmd , rbuf , ibuf ) 
          if( Cmd .eq. 'g') goto 9200 
c         --------------------------- 
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
       end if
#endif
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:       lano =    07/129/sp2.@990422.@152623 ........
contents  2. ardock               subpackage
contents    2.1   ardock              
c ardock-specific
       subroutine ardock (
     i Var , Ar , Kch , Lag , Ndata )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Var ( Kch , Kch ) , Ar ( Kch , Kch , Lag )
       dimension ib ( MAXCH )
       dimension amask ( MAXCH , MAXCH , MAXLAG)
       dimension mask ( MAXCH , MAXCH ) , rmax ( MAXCH ) ,
     * rmax0 ( MAXCH )
       dimension varcor ( MAXCH , MAXCH )
       dimension sqrvar ( MAXCH , MAXCH ) , pbp ( MAXN , MAXCH ) 
       dimension scale ( MAXCH ) , dummy ( MAXCH )  
       character*12 clab  
       character*1 cmd 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR     
       common /cauthor/ mAINT , nMITEX                            
#endif 
c      ........................................................
c      ARdock 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       call areachk (
     i 'ardock' , 'MAXLAG' , MAXLAG , Lag , 1 ,
     o ierr )
       nwdata = nw ('data' , Kch  *  Ndata )
       nwpower = nw ('power' , ( MAXF + 1) * ( Kch  + 1) * Kch )
       nwcoh = nw ('coherence' , ( MAXF + 1) * Kch  * Kch )
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          iw0 = iw ('}' , iw0)
       end if 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('ardock', io , stio )
          call showm2 ('I',
     i    ' Realizes interactive system analysis.',
     i    ' See Section 6, eapecially Fig.1a of CSM.')
          call showr ('I','Var' ,  Var ,   Kch , Kch , Kch )    
          call showr ('I','Ar' ,   Ar ,    Kch , Kch , Kch )
          call showi ('I','Kch' ,  Kch ,   1 , 1 , 1)
          call showi ('I','Lag' ,  Lag ,   1 , 1 , 1)
          call showi ('I','Ndata' ,Ndata , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          iw0 = iw ('{' , 0)
          nw0 = nw ('{' , 0)
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
#ifdef MPI 
       call mpi_bcast ( Lag , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD , 
     * ierr )
       call mpi_bcast ( Kch , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD , 
     * ierr )
#endif 
       mj1 = MAXCH 
       init = Kch 
c      Var normalization 
       do 101 i = 1 , Kch 
       do 100 j = 1 , Kch  
          varcor ( i , j ) = Var ( i , j )     
          sqrvar ( i , j ) = Var ( i , j )  
          if( i .lt. j ) varcor ( i , j ) = Var ( i , j ) / 
     /    dsqrt ( Var ( i , i ) * 
     *    Var ( j , j ))
  100  continue 
  101  continue 
       if( myid .eq. 0) then 
          open ( IOUNIT , file = 'graph.dat')
       if( myid .eq. 0) then 
          write(6,'(/,1x,''ARdock'')')               
       end if 
          write(6 , '(1x  , 3x ,                                             '
     *    ''Variance-covariance/correlation matrix'')')                      ' 
          do 149 i = 1 , Kch 
             write(6 , '(1x , a ,10f7.2)') 
     *       clab ( i ),( varcor ( i , j ) , j = 1 , Kch )
  149     continue 
       end if 
#ifdef AUTHOR 
       call aarry ('cor' ,  - 1 , varcor , Kch   , Kch   , 'd11.3' ,
     * mj1 , mj1 )
#endif    
       call posmat (
     i 'root' , Kch , mj1 , 
     a sqrvar , 
     o det , ierr )
       call maskrs (
     i Kch , 
     o mask ) 
       iscale = 1 
       nblock = Kch 
       do 2201 i = 1 , Kch 
          ib ( i ) = i 
 2201  continue 
catch- call rpar 
       tscale = rpar ('sampling')
       rangl = 0.d0 
       rangh = 0.5d0 
       init = Kch                
       look = 1 
 1088  continue 
c      grouping    
       call gui2 (
     i Kch , init , 
     a nblock , ib )
       if( init .ne. Kch ) goto 1090 
c      --------------------------
 1089  continue 
c      rangl / rangh setting    
       call gui3 (
     i tscale , Kch , init , 
     a rangl , rangh )
 1090  continue 
       init = Kch 
       call subaic (
     i Var , Kch , Lag , Ndata , nblock , ib )                  
       call maskrs (
     i Kch , 
     o mask )     
       do 2221 i = 1 , Kch 
          rmax ( i ) = 0.d0 
          rmax0 ( i ) = 0.d0   
 2221  continue 
       call pwspx (
     i Var , Ar , tscale , rangl , rangh , Kch , Lag , nblock , ib , 
     i mask ,
     o wk ( nwpower ), wk ( nwcoh )) 
       do 5111 jf = 1 , MAXF + 1 
       do 111 ii = 1 , Kch 
c         sum  =  power ( jf , nblock , ii )
          sum  =  wk ( nwpower +           jf 
     *     - 1 +      ( MAXF + 1) * (      nblock 
     *     - 1 +      ( Kch  + 1)   * (         ii 
     *     - 1)))
          if( sum .gt. rmax ( ii ) .and. mod ( jf , 5) .eq. 1)
     *    rmax ( ii ) = sum 
          if( sum .gt. rmax0 ( ii )) rmax0 ( ii ) = sum 
  111  continue 
 5111  continue 
       check = sum 
       init = init - 1 
       initx = 1 
 1008  continue 
c      mask edit
       if( myid .eq. 0) then
          write (6,*) '  presents mask' 
       end if
       call subwin2 (
     i Kch , mask )
       if( initx .eq. 1) then 
          initx = 0 
       else 
          call click2 (
     i    Kch ,
     a    mask ,
     o    look )
       end if 
#ifdef AUTHOR 
       nMITEX = nMITEX + 1 
       call sarry ('group' , nMITEX , ib , 1 , nblock , 'i2' , 1 ,
     * nblock )
       call snum ('rangl' , nMITEX , rangl , '( f10.6)') 
       call snum ('rangh' , nMITEX , rangh , '( f10.6)') 
       call sarry ('mask' , nMITEX , mask , Kch , Kch , 
     * 'i2' , Kch , Kch )
#endif 
 1023  continue
       if( iscale .eq. 1) then 
          call pwevol (
     i    Var , Ar , Lag , Kch , Ndata , mask , 
     o    pbp , scale )
          iscale = 0 
       else 
          call pwevol (
     i    Var , Ar , Lag , Kch , Ndata , mask , 
     o    pbp , dummy )
       end if 
 1022  continue 
       call pwspx (
     i Var , Ar , tscale , rangl , rangh , Kch , Lag , nblock ,
     i ib , mask , 
     o wk ( nwpower ), wk ( nwcoh ))
 1002  continue 
       call bug (1,0,0,0,'gui1', look , check , message )
       call gui1 (
     i Kch ,  
     a look , 
     o cmd , inpx )
#ifdef AUTHOR  
       if( mAINT .eq. 1 .and. cmd .eq. '!') then 
          call design ( Kch , mask , nblock , ib , look )
          goto 1002    
       end if 
#endif 
       if( cmd .eq. 'q') goto 9100 
       if( cmd .eq. 'B') goto 1088 
       if( cmd .eq. 'F') goto 1089 
       if( cmd .eq. 'm') goto 1008 
       if( cmd .eq. 'a') then
          call autodock (
     i    scale , Var , Ar , Kch , Lag , Ndata , 
     w    pbp ) 
          check = pbp (1,1)
          call maskrs (
     i    Kch , 
     o    mask ) 
          goto 1023 
c         ========= 
       end if 
c      ------
       if( cmd .eq. 'c') then 
catch-    call rpar 
          call cohgraph (
     i    wk ( nwcoh ),
     i    wk ( nwpower ) , rmax , rpar ('sampling') , rangl , rangh , 
     i    look , inpx , MAXF + 1 , Kch , nblock , ib )
          check = wk (nwcoh ) 
          goto 1002 
c         =========
       end if 
c      ------
       if( cmd .eq. 'p') then 
          call pbpgraph (
     i    scale , pbp , Kch , Ndata , look )
          goto 1002 
c          ========= 
       endif 
c      ----- 
       if( cmd .eq.  'P') then 
          if( myid .eq. 0) then 
             call pwfile (
     i       wk ( nwpower ) , rmax0 , rpar ('sampling') , 
     i       rangl , rangh , look , MAXF + 1 , Kch , nblock , ib )
             call pwgraph (
     i       wk ( nwpower ) , rmax , rpar ('sampling') , rangl , rangh , 
     i       look , MAXF + 1 , Kch , nblock , ib )
          end if 
          check = wk ( nwpower )
          goto 1002 
c         ========= 
       endif 
c      ----- 
       call maskedar (
     i Ar , mask , Lag , Kch , 
     o amask )
       call arsimu (
     i amask , sqrvar , rangl , rangh , scale , Kch , Lag ,  
     i Ndata , cmd , look , inpx ,  
     w wk ( nwdata )) 
       check = wk ( nwdata + 10 )
       goto 1002 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:        lano =    08/129/sp2.@990422.@152623 ........
contents    2.2   arsimu              
c ardock-specific
      subroutine arsimu (
     i Ar , Sqrvar , Rangl , Rangh , Scale , Kch , Lag , Ndata , 
     i Cmd, Look , Input , 
     w data )
       implicit real*8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       parameter ( lf1 = MAXF + 1)
       dimension Ar ( Kch , Kch , Lag )
       dimension data ( Ndata , Kch ) , Scale ( MAXCH )   
       dimension Sqrvar ( MAXCH , MAXCH ) , w ( MAXCH )
       dimension gg ( MAXN ) , fc ( lf1) , fs ( lf1)
       character*1 Cmd 
       character*50 ckey , ckeyx , ctype 
       character*20 cpar , clab 
       character*26 cfaxis 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif 
       data looked  / 0 / 
c      ........................................................
c      arsimu ,  a subroutine of ARdock 
c      Copyright_OML 1999 M. Ishiguro & K. Sato  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine is for simulations and graphical output.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9       
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arsimu', io , stio )
          call showm ('I',
     i    ' Executes simulations by the basic model(2.1) of CSM.')
          call showm3 ('I',
     i    ' Cmd        input                 output',
     i    '  i  impulse function(3.50)    impulse response(3.52)',
     i    '  s  step function(3.58)       step response(3.59)   ')
          call showm2 ('I',
     i    '  f  trigonometric func.(3.54) frequency response(3.56)',
     i    '  n  simulated innovation(2.2) simulated time series ')
          call showr ('I','Ar' ,     Ar ,      Kch , Kch , Kch )      
          call showr ('I','Sqrvar' , Sqrvar ,  MAXCH , Kch , Kch )
          call showr ('I','Rangl' ,  Rangl ,   1 , 1 , 1)
          call showr ('I','Rangh' ,  Rangh ,   1 , 1 , 1)
          call showr ('I','Scale' ,  Scale ,   1 , 1 , Kch )
          call showi ('I','Kch' ,    Kch ,     1 , 1 , 1)
          call showi ('I','Lag' ,    Lag ,     1 , 1 , 1)
          call showi ('I','Ndata' ,  Ndata ,   1 , 1 , 1)
          call showc ('I','Cmd',     Cmd ,     1,1,1)
          call showi ('I','Look' ,   Look ,    1 , 1 , 1)
          call showi ('I','Input' ,  Input ,   1 , 1 , 1)
          call showw ('data' ,   Ndata , Kch )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Cmd .eq. ' ') goto 9100
c      --------------------------
       if( Cmd .eq. 'n' .and. Look .ne. looked .and.
     * looked .ne. 0) then 
          looked = Look 
          goto 555 
       end if 
c      ------
       looked = Look 
c      ar model 
  100  continue 
       acc = 0.d0     
       n  =  Ndata       
       if( Input .ge. 1 .and. Input .le. Kch ) then       
          if( n .gt. 100 + Lag ) n  =  100 + Lag       
       end if 
       do 510 ii = Lag + 1 , n 
       do 10  i = 1 , Kch     
          sum = 0.d0       
          ltem  =  Lag 
          if( ii - Lag  - 1 .lt. ltem ) ltem  =  ii - Lag - 1  
          if( ltem .gt. 0) then     
             do 511  j = 1 , Kch    
             do 11  l = 1 , ltem     
                sum  =  sum + Ar ( i , j , l ) * 
     *          data ( ii - l , j )
   11        continue 
  511        continue 
          end if  
          if( Input .ge. 1 .and. Input .le. Kch ) then 
             ad  =  0.d0       
             if( i .eq. Input ) then 
                if( ii .eq. Lag + 1) ad  =  1.d0       
                if( ii .gt. Lag + 1 .and. 
     *          ii .le. Lag *2 + 1) then    
                   ad  =   - Ar ( i , i , ii - Lag - 1)   
                end if  
                if( Cmd .eq. 's') then     
                   ad  =  ad + acc 
                   acc  =  ad       
                end if       
             end if       
             data ( ii , i )  =  sum + ad     
          end if 
          if( Cmd .eq. 'n') then 
catch-       call rnor 
             w ( i ) = rnor (1.d0)
             sumr = 0.d0       
             do 1496 k = 1 , i 
                sumr = sumr + w ( k ) *  Sqrvar ( i , k )     
 1496        continue       
             data ( ii , i ) = sumr + sum    
          end if 
   10  continue 
  510  continue 
  555  continue 
       if( Input .lt. 1 .or. Input .gt. Kch ) goto 9201  
       nt = n - Lag 
       scalef  =  dsqrt ( Scale ( Input ) / Scale ( Look ))
       do 1134 i = 1 , nt 
          gg ( i ) = data ( Lag + i , Look ) * scalef  
 1134  continue 
       if( Cmd .eq. 'f') goto  9202    
c      --------------------------- 
       if( Cmd .eq. 'i') then     
          ckey  =  'response to impulse$'
          ctype  =  'timeseries'   
          iskip0 = 1     
#ifdef    AUTHOR 
          label = nMITEX * 1000 + Look * 10 + Input 
          call smat ('inpresp' , label , gg , 
     *    nt , 1 , '(7d11.3)' , nt , 1)     
#endif 
       end if     
       if( Cmd .eq. 's') then     
          ckey  =  'response to step$'
          ctype  =  'timeseries'   
          iskip0 = 0       
#ifdef    AUTHOR 
          label = nMITEX * 1000 + Look * 10 + Input 
          call smat ('stpresp' , label , gg , 
     *    nt , 1 , '(7d11.3)' , nt , 1)
#endif 
       end if 
       if( myid .eq. 0) then 
          sum  =  0.d0 
          do 9931 i = 1 , nt 
             sum  =  sum + gg ( i ) *  * 2 
 9931     continue 
          do 9932 i = 1 , 50 
catch-       call clab 
             if( ckey ( i:i ) .eq. '$') then 
                ckeyx = ckey (1:i - 1) // ':' // clab ( Input )
                ckey = ckeyx 
                goto 9933
c                ========= 
             end if 
c         --------- 
 9932     continue 
 9933     continue 
catch-    call cpar 
catch-    call rpar 
          call gfile (
     i    ctype , ckey , clab ( Look ) , cpar ('unit') , 
     i    0.d0 , rpar ('sampling') , gg ,  - 3.d0 , 3.d0 , 0.d0 , 
     i    nt , 1 , 1 , Look )
          if( myid .eq. 0) write(6,*) ckey 
          call lgraph (
     i    gg , nt , 0.d0 , clab ( Look ) , 1.d0 ,  - 2.d0 , 2.d0 , 
     i    0.d0 , rpar ('sampling') , cpar ('unit') , 20 , iskip0)
       end if 
       goto 9100 
c      ========= 
 9202  continue 
       ckey  =  'frequency response to$'
       ctype  =  'timeseries'   
       lf = lf1 - 1     
       lgp1  =  lf1 
       do 1122 i = 1 , lgp1     
          gg ( i ) = data ( Lag + i , Look ) * scalef 
 1122  continue 
       call fouger (
     i Rangl , Rangh , gg , lgp1 , lf1 , 
     o fc , fs )    
       do 1133 i = 1 , lf1       
          gg ( i ) = dsqrt ( fc ( i ) *  * 2 + fs ( i ) *  * 2)
 1133  continue 
#ifdef AUTHOR 
       label = nMITEX * 1000 + Look * 10 + Input 
       call smat ('frqresp' , label , gg , 
     * lf1 , 1 , '(7d11.3)' , lf1 , 1)    
#endif 
       if( myid .eq. 0) then 
catch-    call rpar 
          rtc  =  1.d0 / rpar ('sampling')
          df  =  ( Rangh - Rangl ) / lf * rtc 
          do 8832 i = 1 , 50 
             if( ckey ( i:i ) .eq. '$') then 
                ckeyx = ckey (1:i - 1) // ':' // clab( Input )
                ckey = ckeyx 
                goto 8833
c                ========= 
             end if 
c         --------- 
 8832     continue 
 8833     continue 
catch-    call cpar 
catch-    call clab 
          cfaxis = 'cycle / ' // cpar ('unit')
          call gfile (
     i    ctype , ckey , clab ( Look ) , 
     i    cfaxis , Rangl * rtc , df , gg ,  - 3.d0 , 3.d0 , 
     i    0.d0 , lf1 , 1 , 1 , Look )
          if( myid .eq. 0) write(6,*) ckey 
          call lgraph (
     i    gg , lf1 , 0.d0 , clab ( Look ) , 1.d0 , -2.d0 , 2.d0 , 
     i    Rangl * rtc , df , cfaxis , 17 , 0)
       end if             
       goto 9100 
c      ========= 
 9201  continue       
       if( Cmd .eq. 'n') then     
          ckey  =  'simulation with generated noise'
          ctype  =  'timeseries'   
          if( myid .eq. 0) write(6,*) ckey 
#ifdef    AUTHOR 
          label = nMITEX * 1000 + Look * 10 
          call smat ('simgen' , label , data (1 , Look ) , n , 1 , 
     *    '(7d11.3)' , n , 1) 
#endif 
       end if     
       if( myid .eq. 0) then 
          ynorm = dsqrt ( Scale ( Look ))
          ynorm10 = ynorm * 10.d0 
catch-    call cpar 
catch-    call clab 
catch-    call rpar 
          call gfile (
     i    ctype , ckey , clab ( Look ) , cpar ('unit') , 
     i    0.d0 , rpar ('sampling') , data (1 , Look ) ,  - ynorm10 , 
     i    ynorm10 , 
     i    0.d0 , n , 1 , 1 , Look )
          call lgraph (
     i    data (1 , Look ) , n , 0.d0 , clab ( Look ) , ynorm , -10.d0 , 
     i    10.d0 , 0.d0 , 
     i    rpar ('sampling') , cpar ('unit') , 20 , 0)
       end if  
       goto 9100 
      end    
#endif

#ifdef ARDOCKLINK
checkpoint:         lano =    09/129/sp2.@990422.@152623 ........
contents    2.3   maskedar            
c ardock-specific
      subroutine maskedar (
     i Ar , Mask , Lag , Kch , 
     o Amask )            
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension  Ar ( Kch , Kch , Lag ), 
     * Amask ( Kch , Kch , Lag ), Mask ( Kch , Kch )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      maskedar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('maskedar', io , stio )                  
          call showm ('I',
     i    ' Produces masked AR model(3.61) of CSM.')
          call showr ('I','Ar' ,    Ar ,     Kch , Kch , Kch )
          call showi ('I','Mask' ,  Mask ,   Kch , Kch , Kch )     
          call showi ('I','Lag' ,   Lag ,    1 , 1 , 1)
          call showi ('I','Kch' ,   Kch ,    1 , 1 , 1)    
          call showr ('O','Amask' ,   Amask ,     Kch , Kch , Kch )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 12  i = 1 , Kch 
       do 11  j = 1 , Kch 
          do 10  l = 1 , Lag 
             if( i .ne. j ) then 
                Amask ( i , j , l ) = 
     *          Ar ( i , j , l )  *  Mask ( i , j )
             else 
                Amask ( i , j , l )  =  Ar ( i , j , l ) 
             end if     
   10     continue     
   11  continue     
   12  continue     
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:          lano =    10/129/sp2.@990422.@152623 ........
contents    2.4   autodock            
c ardock-specific
      subroutine autodock (
     i Scale , Var , Ar , Kch , Lag , Ndata , 
     w pbp )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Var ( Kch , Kch ) , Ar ( Kch , Kch , MAXLAG) ,
     * Scale ( Kch )
       dimension Mask ( MAXCH * MAXCH )
       character*1 csmr (0:MAXCH , 0:MAXCH ) , ca 
       character*1 cstr (0:MAXCH , 0:MAXCH , MAXCH ) , cp , cm , cb ,
     * bb (0:MAXCH )
       dimension pwx ( MAXCH * MAXCH ) , pbp ( MAXN , MAXCH )
       dimension str (0:MAXCH , 0:MAXCH , MAXCH ) , 
     * smr (0:MAXCH , 0:MAXCH , 2) ,
     * iwset ( MAXCH )
       character*1 ckey 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif 
       character*10 clab  
       data cb /' '/, cp /'+'/, cm /'-'/, cstr /1210 * ' '/
       data ca /'*'/, csmr /121 * ' '/  
       data bb /'*','1','2','3','4','5','6','7','8','9','0' / 
c      ........................................................
c      autodock 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('autodock', io , stio )                  
          call showm2 ('I',
     i    ' Produces feedback characteristic matrix(3.62) ',
     i    ' for given watching set of variables.') 
          call showr ('I','Scale' , Scale ,     1 , 1 , Kch )     
          call showr ('I','Var' ,   Var ,       Kch , Kch , Kch )
          call showr ('I','Ar' ,    Ar ,        Kch , Kch , Kch )
          call showi ('I','Kch' ,   Kch ,       1 , 1 , 1)    
          call showi ('I','Lag' ,   Lag ,       1 , 1 , 1)
          call showi ('I','Ndata' , Ndata ,     1 , 1 , 1)    
          call showw ('pbp' ,   Ndata ,     Kch )     
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .eq. 0) then   
          write(6,'(2x,''channels are        :'',5A)') 
     *    ( clab ( j ), j = 1, kCH )
          call keysave 
     *    ('i','specify watching set:', Kch , ckey , rx , iwset )
       end if 
#ifdef MPI 
       call mpi_bcast ( iwset , Kch , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
#endif 
       do 1357 j = 0 , Kch 
          do 1358 i = 0 , Kch  
             smr ( i , j , 1) = 1.d20 
             smr ( i , j , 2) =  - 1.d20 
 1358     continue 
          smr ( j , j , 1) = 1.d0  
          smr ( j , j , 2) = 1.d0 
 1357  continue     
       ista = 1 
       iend  =  Kch  * ( Kch  - 1)
       call mpion (
     o mpiflag )
       if( mpiflag .eq. 1) then 
          call mpison (
     i    1 , Kch  * ( Kch  - 1) , 
     o    ista , iend )
       end if 
       do 6666 i = ista , iend 
          iswar = ( i - 1) / ( Kch  - 1)
          iswac = i - iswar * ( Kch  - 1)
          iswar = iswar + 1 
          if( iswac .ge. iswar ) iswac = iswac + 1 
          call maskrs (
     i    Kch , 
     o    Mask ) 
c          if( myid .eq. 0) write(6,*) 'path = ' , iswar , iswac 
          iiix = iiix + 1 
          Mask ( iswar +  Kch  * ( iswac - 1))  =  0 
          call pwevol (
     i    Var , Ar , Lag , Kch , Ndata , Mask , 
     o    pbp , pwx (( i - 1) * Kch  + 1))
 6666  continue 
#ifdef MPI 
       call mpioff (
     i mpiflag )
       if( mpiflag .eq. 1) then 
          ircntr = ( iend - ista + 1) * Kch 
          idispr = ( ista - 1) * Kch 
          call mpisres (
     i    idispr + 1 , ircntr )
          call mpisoff (
     i    pwx ( idispr + 1) , ircntr , MPI_DOUBLE_PRECISION , 
     o    pwx )
       end if 
#endif 
       do 8888 iswar = 1 , Kch 
       do 8887 iswac = 1 , Kch 
          if( iswac .eq. iswar ) goto 8887 
c         ------------------------------
          irc  =  ( iswar - 1) * ( Kch  - 1) + iswac 
          if( iswac .gt. iswar ) irc = irc - 1 
          irc = irc - 1 
          do 3002 ixp = 1 , Kch 
             str ( iswar , iswac , ixp ) = pwx ( irc * Kch  + ixp ) / 
     /       Scale ( ixp )
             if( iwset ( ixp ) .eq. 1) then 
                if( str ( iswar , iswac , ixp ) .lt. 
     *          smr ( iswar , iswac , 1))  
     *          smr ( iswar , iswac , 1) = str ( iswar , iswac , ixp ) 
                if( str ( iswar , iswac , ixp ) .gt. 
     *          smr ( iswar , iswac , 2)) 
     *          smr ( iswar , iswac , 2) = str ( iswar , iswac , ixp )  
             end if 
             cstr ( iswar , iswac , ixp ) = cb 
             if( str ( iswar , iswac , ixp ) .gt. 1.1) 
     *       cstr ( iswar , iswac , ixp ) = cm   
             if( str ( iswar , iswac , ixp ) .lt. 0.9) 
     *       cstr ( iswar , iswac , ixp ) = cp 
 3002     continue 
 1666     format(1x  , 'psum / psum0 = ' , f10.5)     
 8887  continue 
 8888  continue 
       if( myid .ne. 0) goto 9100  
c      ------------------------- 
       do 1222 ixp = 1 , Kch 
          write(6 , 6) 
          write(6,*) ' '
          write(6,*) 'feedback character matrix with respect to the',
     *    ixp , '-th variable'
          write(6,*) ' '
          do 2345 ir = 1 , Kch 
             write(6 , 1223) 
     *       clab ( ir ),( str ( ir , ic , ixp ) , ic = 1 , Kch ) 
 2345     continue 
          write(6,*) ' ' 
          write(6 , 1224) 
     *    '          ','  ' , ( bb ( ic ) , ic = 1 , Kch ) , '  ' 
          do 2347 ir = 1 , Kch 
             write(6 , 1224) clab ( ir ), bb ( ir ) , 
     *       ( cstr ( ir , ic , ixp ) , ic = 1 , Kch ) , bb ( ir )
 2347     continue 
          write(6 , 1224) 
     *    '          ','  ' , ( bb ( ic ) , ic = 1 , Kch ) , '  ' 
          write(6,*) ' '
 1222  continue 
       write(6 , 6)   
    6  format(1x ) 
       write(6,*) 'summary' 
       write(6,*) 'feedback character matrix with respect to the'
       write(6,*) '   watching set:',( iwset ( i ) , i = 1 , Kch )
       do 5468 i = 1 , Kch 
       do 2468 j = 1 , Kch 
          if( j .eq. 0) then 
          if( i .ne. 0) then 
             smr ( i , j , 1) = str ( i , j , i )
             smr ( i , j , 2) = str ( i , j , i )
          end if 
          end if 
          if( smr ( i , j , 1) .gt. 0.9) then 
             if( smr ( i , j , 2) .lt. 1.1) then            
                csmr ( i , j ) = cb                           
             else  
                csmr ( i , j ) = cm                           
             end if 
          else 
             if( smr ( i , j , 2) .lt. 1.1) then            
                csmr ( i , j ) = cp                           
             else  
                csmr ( i , j ) = ca                           
             end if 
          end if   
 2468  continue     
 5468  continue     
       write(6,*) 'maximum'
       do 9456 ir = 1 , Kch   
          write(6 , 1223) 
     *    clab ( ir ),( smr ( ir , ic , 2) , ic = 1 , Kch )
 1223     format(1x  , a, 10 ( f6.1 , ' '))                       
 9456  continue 
       write(6,*) 'minimum'
       do 3456 ir = 1 , Kch   
          write(6 , 1223) 
     *    clab ( ir ),( smr ( ir , ic , 1) , ic = 1 , Kch )
 3456  continue 
       write(6,*) 'diagram'
       write(6 , 1224) 
     * '          ', '  ' , ( bb ( ic ) , ic = 1 , Kch ) , '  '     
 1224  format(1x  , a,12a2)
       do 3457 ir = 1 , Kch   
          write(6 , 1224) clab ( ir ), bb ( ir ) , 
     *    ( csmr ( ir , ic ) , ic = 1 , Kch ) , bb ( ir )
 3457  continue 
       write(6 , 1224) 
     * '          ','  ' , ( bb ( ic ) , ic = 1 , Kch ) , '  '     
       write(6,*) ' '
       goto 9100 
      end 
#endif

checkpoint:           lano =    11/129/sp2.@990422.@152623 ........
contents    2.5   subaic              
c reusable
      subroutine subaic (
     i Var , Kch , Lag , Ndata , Nblock , Ib )         
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Var ( Kch , Kch ) , sdtem ( MAXCH , MAXCH ) 
       dimension Ib ( Nblock )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif 
       data init  / 1 /, pi /0.0/, aic0 /0.d0/
c      ........................................................
c      subaic        
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subaic', io , stio )                  
          call showm2 ('I',
     i    ' Evaluates the goodness of block diagonal structure',
     i    ' of innovation matrix(3.44) of CSM.')
          call showm2 ('I',
     i    ' d_AIC is the difference of AIC(4.78) and AIC(4.71)',
     i    ' of the ordinary MAR model(2.4).')
          call showr ('I','Var' ,   Var ,       Kch , Kch , Kch )     
          call showi ('I','Kch' ,   Kch ,       1 , 1 , 1)
          call showi ('I','Lag' ,   Lag ,       1 , 1 , 1)
          call showi ('I','Ndata' , Ndata ,     1 , 1 , 1)    
          call showi ('I','Nblock' ,Nblock ,    1 , 1 , 1)
          call showi ('I','Ib' ,    Ib ,        1 , 1 , Nblock )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       aic = 2.d0 * Lag * Kch  *  * 2 
       if( init .eq. 1) then   
          init  =  0     
          pi  =  atan2 (0.d0 ,  - 1.d0) 
          do 577 jj = 1 , Kch 
          do 887 kk = 1 , Kch     
             sdtem ( jj , kk ) = Var ( jj , kk )
  887     continue 
  577     continue     
          call posmat (
     i    'root' , Kch , 10 , 
     a    sdtem , 
     o    xdet , ierr )
          aic0  =  aic + Ndata  * Kch  *  dlog (2.d0 *  pi ) + Ndata  *  
     *    dlog ( xdet )  + 
     *    Ndata  * Kch + ( Kch  + 1) * Kch 
       end if 
       je = 0 
       do 111 jgrp = 1 , Nblock     
          js = je + 1 
          je0 = je 
          je = Ib ( jgrp ) 
          ip0 = je - je0  
          do 11 jj = js , je 
          do 13 kk = js , je   
             sdtem ( jj - je0 , kk - je0) = Var ( jj , kk ) 
   13     continue   
   11     continue     
          call posmat (
     i    'root' , ip0 , 10 , 
     a    sdtem , 
     o    xdet , ierr )
          aic  =  aic + Ndata  *  ip0 *  dlog (2.d0 * pi ) + 
     *    Ndata  *  dlog ( xdet )  + 
     *    Ndata  *  ip0 + ( ip0  + 1) *  ip0 
  111  continue 
#ifdef ARDOCKLINK
       aic  =  aic - aic0 
       if( myid .eq. 0) then 
          write(6 , 66) ( Ib ( i ) , i = 1 , Nblock )
   66     format( /  , 1x  , 'block diagonal model:' , 10i3)               
          write(6 , 60) aic                           
   60     format(  1x  , '               ( d_AIC  = ' , f10.2 , ')')          
#else
       if( myid .eq. 0) then 
          write(6 , 66) ( Ib ( i ) , i = 1 , Nblock )
   66     format( /  , 1x  , 'block diagonal model:' , 10i3)               
          write(6 , 60) aic                           
   60     format(  1x  , '    AIC  = ' , f10.2 )       
#endif
#ifdef    AUTHOR 
          call snum ('daic' , nMITEX , aic , '( f10.2)')
#endif 
       end if             
       goto 9100 
      end  

#ifdef ARDOCKLINK
checkpoint:            lano =    12/129/sp2.@990422.@152623 ........
contents    2.6   pbpgraph            
c ardock-specific
      subroutine pbpgraph (
     i Scale , Pbp , Kch , Ndata , Look ) 
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Pbp ( MAXN , MAXCH ) , Scale ( Kch )
       character*20 cpar , clab 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif 
c      ........................................................
c      pbpgraph 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pbpgraph', io , stio )                  
          call showm2 ('I',
     i    ' Displays power building profile(3.35) on the',
     i    ' character display')
          call showr ('I','Scale' ,    Scale ,    1 , 1 , Kch )     
          call showr ('I','Pbp' ,      Pbp ,      MAXN , Ndata , Kch )    
          call showi ('I','Kch' ,      Kch ,      1 , 1 , 1)
          call showi ('I','Ndata' ,    Ndata ,    1 , 1 , 1)
          call showi ('I','Look' ,     Look ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       n = Ndata 
       if( n .gt. 100) n = 100 
       if( myid .eq. 0) then  
          ynorm = Scale ( Look )    
          ynorm10 = ynorm * 2.d0 
catch-    call clab 
catch-    call cpar 
catch-    call rpar 
          call gfile (
     i    'timeseries' , 'power building profile' , 
     i    clab ( Look ) , cpar ('unit') , 
     i    0.d0 , rpar ('sampling') , Pbp (1 , Look ) ,  - ynorm10 ,
     i    ynorm10 , 0.d0 , 
     i    n , 1 , 1 , Look )
          write(6,*) 'power building profile'
          write(6,*)
          call lgraph (
     i    Pbp (1 , Look ) , n , 0.d0 , clab ( Look ) , ynorm , 
     i    - 2.d0 , 2.d0 , 
     i    0.d0 , rpar ('sampling') , cpar ('unit') , 21 , 0)
#ifdef    AUTHOR 
          label = nMITEX * 1000 + Look * 10  
          call smat ('pbp' , label , Pbp (1 , Look ) , n , 1 ,
     *    '(7d11.3)' , n , 1) 
#endif 
       end if 
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:             lano =    13/129/sp2.@990422.@152623 ........
contents    2.7   pwgraph             
c ardock-specific
      subroutine pwgraph (
     i Power , Rmax , Tscale , Rangl , Rangh , Look , Nf , Kch ,
     i Nblock , Ib ) 
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension  Power ( Nf , Kch  + 1 , Kch )  , Rmax ( Kch )
       dimension Ib ( Nblock )
       character*20 cpar , clab , cparu , clabi 
       character*4 lb , lx , li                           
       character*1 la (10) ,  l0 (101)  , l (101)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data lpsize  / 60 / 
       data lb / '    ' / ,  lx / 'x   ' / ,  li / ':   ' / 
       data la / '1','2','3','4','5','6','7','8','9','0' /  
c      ........................................................
c      pwgraph 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pwgraph', io , stio )
          call showm2 ('I',
     i    ' Displays  power spectrum(3.40) and relative',
     i    ' power contribution(3.49) on the character display.')
          call showr ('I','Power' ,     Power ,   Nf , Nf , Nblock )    
          call showr ('I','Rmax' ,      Rmax ,    1 , 1 , Kch )
          call showr ('I','Tscale' ,    Tscale ,  1 , 1 , 1)
          call showr ('I','Rangl' ,     Rangl ,   1 , 1 , 1)
          call showr ('I','Rangh' ,     Rangh ,   1 , 1 , 1)
          call showi ('I','Look' ,      Look ,    1 , 1 , 1)
          call showi ('I','Nf' ,        Nf ,      1 , 1 , 1)
          call showi ('I','Kch' ,       Kch ,     1 , 1 , 1)
          call showi ('I','Nblock' ,    Nblock ,  1 , 1 , 1)
          call showi ('I','Ib' ,        Ib ,      1 , 1 , Nblock )
          call selfend ( myself , io , inisub )
       end if 
#endif 
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       xmin  =  0.d0     
       xmax  =  1.d0     
       unit  =  0.2d0 
       num  =  1.d0 / unit 
       num2  =  num / 2 + 1 
       num = num2 * 2 
       lp  =  lpsize / num 
       mesh  =  lp * num 
       ixmin  =  xmin / unit                      
       xmin  =  ixmin * unit 
       xmax  =  xmin + num * unit 
       xd  =  ( xmax - xmin ) / mesh  
       xd2  =  xd * 0.5   
       xmin2  =  xmin - xd2 
       write(6 , 601) Look                           
  601  format(1x  , 12x , 'spectrum structure of the ' , 
     * i2 , ' - th variable')
catch- call clab 
catch- call cpar 
       cparu = cpar ('unit')
       clabi = clab ( Look )
       write(6,*) 'cycle / ' , cparu , ' :' , clabi 
       do 50  j = 1 , 51  
          if( mod ( j , 10) .eq. 1 ) then                         
             l0 ( j )  =  li 
          else 
             l0 ( j )  =  lb 
          end if 
   50  continue 
       pwmax = Rmax ( Look )
       if( pwmax .le. 0.d0) pwmax = 1.d0 
       df  =  ( Rangh - Rangl ) / ( Nf - 1) / Tscale 
       f0  =  Rangl / Tscale                         
       do 100  i = 1 , Nf 
          do 60  j = 1 , 101 
             l ( j ) = lb 
             if( j .le. 51) l ( j ) = l0 ( j ) 
   60     continue 
          l (69) = li 
          if( mod ( i - 1 , 5) .ne. 0) goto 100   
c         ------------------------------- 
          do 887 kp = Nblock ,1 ,  - 1 
             kgrp = Ib ( kp )     
             if( kp .eq. Nblock ) then 
                item  =  ( 1.d0 - xmin2 ) /  xd + 1 
             else 
                item  =  ( Power ( i , kp , Look ) -  xmin2 ) /  xd + 1 
             end if                       
             l ( item )  =  la ( kgrp )
  887     continue 
          item  =  Power ( i , Nblock , Look ) / pwmax *  15 + 53                    
          if( item .gt. 75) item = 75 
          do 1496 j = 53 , item 
             l ( j ) = lx 
 1496     continue 
          im1 = i - 1 
          write(6 , 1602) im1 * df + f0 ,  ( l ( j ) , j = 1 , 70)        
 1602     format(1x  , f6.2 , 1x , 70a1) 
  100  continue     
       goto 9100 
      end  
#endif

#ifdef ARDOCKLINK
checkpoint:              lano =    14/129/sp2.@990422.@152623 ........
contents    2.8   cohgraph            
c ardock-specific
      subroutine cohgraph (
     i Coherency ,
     i Power , Rmax , Tscale , Rangl , Rangh , Look , 
     i Input , Nf , Kch ,
     i Nblock , Ib ) 
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension  Coherency ( Nf , Kch , Kch ) 
       dimension  Power ( Nf , Kch  + 1 , Kch )  , Rmax ( Kch )
       dimension Ib ( Nblock )
       character*20 cpar , clab , cparu , clabi 
       character*4 lb , lx , li                           
       character*1 la (10) ,  l0 (101)  , l (101)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data lpsize  / 60 / 
       data lb / '    ' / ,  lx / 'x   ' / ,  li / ':   ' / 
       data la / '1','2','3','4','5','6','7','8','9','0' /  
c      ........................................................
c      cohgraph 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('cohgraph', io , stio )
          call showm2 ('I',
     i    ' Displays coherency(3.43) and power spectrum(3.40)',
     i    ' on the character display.')
          call showr ('I','Coherency' , Coherency , Nf , Nf , Kch )    
          call showr ('I','Power' ,     Power ,     Nf , Nf , Nblock )    
          call showr ('I','Rmax' ,      Rmax ,      1 , 1 , Kch )
          call showr ('I','Tscale' ,    Tscale ,    1 , 1 , 1)
          call showr ('I','Rangl' ,     Rangl ,     1 , 1 , 1)
          call showr ('I','Rangh' ,     Rangh ,     1 , 1 , 1)
          call showi ('I','Look' ,      Look ,      1 , 1 , 1)
          call showi ('I','Nf' ,        Nf ,        1 , 1 , 1)
          call showi ('I','Kch' ,       Kch ,       1 , 1 , 1)
          call showi ('I','Nblock' ,    Nblock ,    1 , 1 , 1)
          call showi ('I','Ib' ,        Ib ,        1 , 1 , Nblock )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .ne. 0) goto 9100 
       xmin  =  0.d0     
       xmax  =  1.d0     
       unit  =  0.2d0 
       num  =  1.d0 / unit 
       num2  =  num / 2 + 1 
       num = num2 * 2 
       lp  =  lpsize / num 
       mesh  =  lp * num 
       ixmin  =  xmin / unit                      
       xmin  =  ixmin * unit 
       xmax  =  xmin + num * unit 
       xd  =  ( xmax - xmin ) / mesh  
       xd2  =  xd * 0.5   
       xmin2  =  xmin - xd2 
       write(6 , 601) Look                           
  601  format(1x  , 12x , 'coherency of the ' , 
     * i2 , ' - th variable')
catch- call clab 
catch- call cpar 
       cparu = cpar ('unit')
       clabi = clab ( Look )
       write(6,*) 'cycle / ' , cparu , ' :' , clabi 
       do 50  j = 1 , 51  
          if( mod ( j , 10) .eq. 1 ) then                         
             l0 ( j )  =  li 
          else 
             l0 ( j )  =  lb 
          end if 
   50  continue 
       pwmax = Rmax ( Look )
       if( pwmax .le. 0.d0) pwmax = 1.d0 
       df  =  ( Rangh - Rangl ) / ( Nf - 1) / Tscale 
       f0  =  Rangl / Tscale                         
       do 100  i = 1 , Nf 
          do 60  j = 1 , 101 
             l ( j ) = lb 
             if( j .le. 51) l ( j ) = l0 ( j ) 
   60     continue 
          l (69) = li 
          if( mod ( i - 1 , 5) .ne. 0) goto 100   
c         ------------------------------- 
          item  =  ( Coherency ( i , Input , Look ) - xmin2) / xd + 1 
          l ( item )  =  la ( Input )
          item  =  Power ( i , Nblock , Look ) / pwmax *  15 + 53 
          if( item .gt. 75) item = 75 
          do 1496 j = 53 , item 
             l ( j ) = lx 
 1496     continue 
          im1 = i - 1 
          write(6 , 1602) im1 * df + f0 ,  ( l ( j ) , j = 1 , 70)        
 1602     format(1x  , f6.2 , 1x , 70a1) 
  100  continue     
       goto 9100 
      end  
#endif

checkpoint:               lano =    15/129/sp2.@990422.@152623 ........
contents    2.9   pwfile              
c reusable
      subroutine pwfile (
     i Power , Rmax0 , Tscale , Rangl , Rangh , Look , Nf , Kch ,
     i Nblock , Ib )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension  Power ( Nf , Kch  + 1 , Kch ) , Rmax0 ( Kch )
       dimension Ib ( Nblock )
       character*20 cpar , clab 
       character*26 cfaxis 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      pwfile 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pwfile', io , stio )
          call showm2 ('I',
     i    ' Writes power spectrum and relative power contribution',
     i    ' to a file. See Section 5.4.3 of CSM.')
          call showr ('I','Power' ,     Power ,   Nf , Nf , Nblock )    
          call showr ('I','Rmax0' ,     Rmax0 ,   1 , 1 , Kch )
          call showr ('I','Tscale' ,    Tscale ,  1 , 1 , 1)
          call showr ('I','Rangl' ,     Rangl ,   1 , 1 , 1)
          call showr ('I','Rangh' ,     Rangh ,   1 , 1 , 1)
          call showi ('I','Look' ,      Look ,    1 , 1 , 1)
          call showi ('I','Nf' ,        Nf ,      1 , 1 , 1)
          call showi ('I','Kch' ,       Kch ,     1 , 1 , 1)
          call showi ('I','Nblock' ,    Nblock ,  1 , 1 , 1)
          call showi ('I','Ib' ,        Ib ,      1 , 1 , Nblock )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      =========  
       return 
c      ====== 
 9200  continue 
       io = 'O'
       df  =  ( Rangh - Rangl ) / 80 / Tscale 
       f0  =  Rangl / Tscale       
catch- call clab 
catch- call cpar                   
       cfaxis = 'cycle / ' // cpar ('unit')
       call gfile (
     i 'spectrum' , 'Power Spectrum' , 
     i clab ( Look ) , cfaxis , 
     i f0 , df , Power (1 , Nblock , Look ) , 
     i 0.d0 , Rmax0 ( Look ) , 0.d0 , Nf , 1 , 1 , Look )
       call gfile (
     i 'contribution' , 'Power Contribution' , 
     i clab ( Look ) , cfaxis , f0 , df , 
     i Power (1 , 1 , Look ) , 0.d0 , 1.d0 , 0.d0 , 
     i Nf , Nblock - 1 , Nblock , Ib )
       goto 9100 
      end 

#ifdef ARDOCKLINK
checkpoint:                lano =    16/129/sp2.@990422.@152623 ........
contents    2.10  gui1                
c ardick-specific
      subroutine gui1 (
     i Kch ,  
     a Look , 
     o Cmd , Inpx )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1 Cmd, cmdp 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
       data cmdp  / 'p' / 
c      ........................................................
c      gui1 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gui1', io , stio )                  
          call showm ('I',
     i    ' Interprets an interactive analysis command. ')
          call showi ('I','Kch' ,  Kch ,      1 , 1 , 1)
          call showi ('A','Look',  Look ,     1 , 1 , 1)
          call showc ('O','Cmd' ,  Cmd ,      1 , 1 , 1)    
          call showi ('O','Inpx',  Inpx ,     1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call subwin1 (
     i Kch , Look )
       call click1 (
     o Cmd , iarg1)
       kxp = 0 
       if( Cmd  .eq. 'l') kxp = iarg1  
       if( Cmd  .eq. '1') kxp = 1  
       if( Cmd  .eq. '2') kxp = 2  
       if( Cmd  .eq. '3') kxp = 3  
       if( Cmd  .eq. '4') kxp = 4  
       if( Cmd  .eq. '5') kxp = 5   
       if( Cmd  .eq. '6') kxp = 6  
       if( Cmd  .eq. '7') kxp = 7  
       if( Cmd  .eq. '8') kxp = 8  
       if( Cmd  .eq. '9') kxp = 9  
       if( Cmd .eq. 'N') then 
          kxp = Look + 1 
          if( kxp .gt. Kch ) kxp = 1 
       end if 
       if( kxp .ge. 1 .and. kxp .le. Kch ) then 
          Look = kxp 
          Cmd = cmdp 
          iarg1 = iargp 
       end if 
#ifdef AUTHOR 
       if( mAINT .eq. 1 .and. Cmd .eq. '!') then 
          goto 9100 
       end if 
#endif 
       if( iarg1 .eq. 0) iarg1  =  iargp 
       if( Cmd .eq. 'p') then 
          kxp =  - 1 
       end if 
       if( Cmd .eq. 'P') then 
          kxp =  - 1 
       end if 
       if( Cmd .eq. 'c') then 
          kxp =  - 1 
          Inpx  =  iarg1 
       end if 
       if( Cmd .eq. 'i') then 
          kxp =  - 1 
          Inpx  =  iarg1 
cc          istepx  =  0 
       end if 
       if( Cmd .eq. 's') then 
          kxp =  - 1 
          Inpx  =  iarg1 
cc          istepx  =  1 
       end if 
       if( Cmd .eq. 'f') then 
          kxp =  - 1 
          Inpx  =  iarg1 
cc          istepx  =  2 
       end if 
       if( Cmd .eq. 'n') then 
          kxp =  - 1 
          Inpx  =   - 1 
       end if 
       if( Cmd .eq. 'G') then 
          iarg1 = iargp 
         goto 9100 
       end if 
       if( Cmd .eq. 'F') then 
          iarg1 = iargp 
         goto 9100 
       end if 
       if( Cmd .eq. 'q') then 
         goto 9100 
       end if 
       if( Cmd .eq. 'a') then 
         goto 9100 
       end if 
       if( kxp .eq.  - 1) then 
          iargp  =  iarg1 
          cmdp = Cmd 
       end if 
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:                 lano =    17/129/sp2.@990422.@152623 ........
contents    2.11  gui2                
c ardock-specific
      subroutine gui2 (
     i Kch , Init , 
     a Nblock , Ib )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Ib (10)
       character*1 cbuf 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      gui2 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gui2', io , stio )                  
          call showm ('I',
     i    ' Prompts the user to set block structure(3.45).')
          call showi ('I','Kch' ,       Kch ,       1 , 1 , 1)
          call showi ('I','Init' ,      Init ,      1 , 1 , 1)     
          call showi ('A','Nblock' ,    Nblock ,    1 , 1 , 1)
          call showi ('A','Ib' ,        Ib ,        1 , 1 , Nblock )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Init .eq. Kch ) goto 9100 
c      prompt 
       if( myid .eq. 0) write(6,*) 'choose from:' ,
     * ( i , i = 1 , Kch )   
c      get iNFO 
       lans = 0 
       nblock1 = 1 
       Ib ( nblock1 ) = Kch 
       Nblock = 1 
       if( myid .eq. 0) then 
 2202     continue   
          call keysave 
     *    ('i','block boundary:' , 1 , cbuf , rbuf , ians )
          if( ians .gt. lans .and. ians .le. Kch ) then 
             Ib ( nblock1) = ians 
             Nblock = nblock1 
             if( ians .lt. Kch ) then  
                nblock1 = nblock1 + 1 
                Ib ( nblock1) = Kch 
                Nblock = nblock1  
                lans = ians  
                goto 2202 
c                =========    
             end if  
c            ------
          end if     
       end if 
#ifdef MPI 
       call mpi_bcast ( Nblock , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast ( Ib , Nblock , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
#endif
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:                  lano =    18/129/sp2.@990422.@152623 ........
contents    2.12  gui3                
c ardock-specific
      subroutine gui3 (
     i Tscale , Kch , Init , 
     a Rangl , Rangh )
       implicit real*8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1 cbuf 
       dimension rbuf (2)     
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      gui3 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gui3', io , stio )                  
          call showm ('I',
     i    ' Prompts the user to set frequency  range')
          call showr ('I','Tscale' ,    Tscale ,   1 , 1 , 1)    
          call showi ('I','Kch' ,       Kch ,      1 , 1 , 1)
          call showi ('I','Init' ,      Init ,     1 , 1 , 1)     
          call showr ('A','Rangl' ,     Rangl ,    1 , 1 , 1)
          call showr ('A','Rangh' ,     Rangh ,    1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Init .eq. Kch ) goto 9100 
       if( myid .eq. 0) then 
          call keysave ('r','frequency band:' , 
     *    2 , cbuf , rbuf , kbuf )
          Rangl = rbuf (1) * Tscale 
          Rangh = rbuf (2) * Tscale 
          if( Rangl .gt. 0.5d0) Rangl = 0.d0 
          if( Rangh .gt. 0.5d0) Rangh = 0.d0 
       end if 
#ifdef MPI 
       call mpi_bcast ( Rangl , 1 , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
       call mpi_bcast ( Rangh , 1 , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
       call mpi_bcast ( Tscale , 1 , MPI_DOUBLE_PRECISION , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:                   lano =    19/129/sp2.@990422.@152623 ........
contents    2.13  click1              
c ardock-specific
      subroutine click1 (
     o Cmd , Iarg1 )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1 Cmd 
       dimension iarg (50)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      .........................................................
c      click1 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('click1', io , stio )                  
          call showm ('I',
     i    ' Accepts an interactive analysis command.')
          call showc ('O','Cmd' ,   Cmd ,     1 , 1 , 1)
          call showi ('O','Iarg1' , Iarg1 ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .eq. 0) then 
catch-    call jfrex 
          j = j 
          j  =  jfrex ('init' , 1)
          j = jfrex ('l' , 1)
          j = jfrex ('q' , 0)
          j = jfrex ('B' , 0)
          j = jfrex ('F' , 0)
          j = jfrex ('w' , 0)
          j = jfrex ('f' , 1)
          j = jfrex ('s' , 1)
          j = jfrex ('c' , 1)
          j = jfrex ('i' , 1)
          j = jfrex ('p' , 0)
          j = jfrex ('b' , 0)
          j = jfrex ('m' , 0)
          j = jfrex ('1' , 0)
          j = jfrex ('2' , 0)
          j = jfrex ('3' , 0)
          j = jfrex ('4' , 0)
          j = jfrex ('5' , 0)
          j = jfrex ('6' , 0)
          j = jfrex ('7' , 0)
          j = jfrex ('8' , 0)
          j = jfrex ('9' , 0)
          j = jfrex ('n' , 0)
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
          if( mAINT .eq. 1 ) 
     *    j = jfrex ('!' , 0)
#endif
          call keysave ('I','ARdock:', Id , Cmd , rx , iarg )
          Iarg1  =  iarg (1) 
       end if 
#ifdef MPI 
       call mpi_bcast ( Cmd , 1 , mpi_byte , 0 , MPI_COMM_WORLD ,
     * ierr )
       call mpi_bcast ( Iarg1 , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
#endif 
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:                    lano =    20/129/sp2.@990422.@152623 ........
contents    2.14  click2              
c ardock-specific
      subroutine click2 (
     i Kch , 
     a Mask , 
     o Look )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Mask ( Kch , Kch ) , iarg (10)
       character*1 cx  
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      click2          
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('click2', io , stio )
          call showm ('I',
     i    ' Accepts a mask edit command.')
          call showi ('I','Kch' ,  Kch ,   1 , 1 , 1)
          call showi ('A','Mask',  Mask ,  Kch , Kch , Kch )
          call showi ('O','Look',  Look ,  1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
catch- call jfrex 
       j = j 
       j  =  jfrex ('init' , 1)
       j  =  jfrex ('g' , 0)
       j  =  jfrex ('r' , 4)
       j  =  jfrex ('o' , 1)
       goto 1500 
c      ========= 
 1008  continue 
       call subwin2 ( Kch , Mask )
 1500  continue 
corrected2000.01.20 1 line correction made by M.I.
c       call keympi ('I','mask edit: g?r?o?', Kch , cx , rx , iarg )
       call keympi ('I','mask edit: g?r?o?', 4 , cx , rx , iarg )
       i1 = iarg (1)
       if( cx .eq. 'g') goto 9100 
c      ------------------------ 
       if( cx .eq. 'r') then 
          j1 = iarg (2)
          i2 = iarg (3)
          j2 = iarg (4)
       else 
          j1 =  0 
       end if 
       if( j1 .ne. 0) then 
          do 2100 ii = i1 , i2 
          do 2101 jj = j1 , j2   
             if( ii .ne. jj ) Mask ( ii , jj ) = 1 - Mask ( ii , jj ) 
 2101     continue 
 2100     continue 
       else 
          do 3100 ii = 1 , Kch 
             do 3101 jj = 1 , Kch 
                if( ii .eq. i1) then 
                   Mask ( ii , jj )  =  1 
                else 
                   Mask ( ii , jj )  =  0 
                end if 
 3101        continue 
             Mask ( ii , ii ) = 1 
 3100     continue 
          Look = i1 
       end if  
       goto 1008 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:                     lano =    21/129/sp2.@990422.@152623 ........
contents    2.15  subwin1             
c ardock-specific
      subroutine subwin1 (
     i Kch , Look )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       character*20 clab , clabuf 
c      ........................................................
c      subwin1 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subwin1', io , stio )                  
          call showm ('I',
     i    ' Prompts the user for an interactive analysis command.')
          call showi ('I','Kch' ,   Kch   ,   1 , 1 , 1)     
          call showi ('I','Look' ,  Look ,    1 , 1 , 1)     
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
catch- call clab 
       clabuf = clab (Look )
       if( myid .eq. 0) then 
          write(6,'(1x,i2,'':'',A,                                           '
     *    '' menu: q)uit m)ask F)band B)lock'',
     *    '' l)ook <1-'',I2,''>  N)ext'')')  Look , clabuf , Kch             '
          write(6,'(''    p)bp  P)ower'',                                    '
     *    ''  n)oise  i)mpulse *  s)tep *  f)req *  c)oherency * '')')       '
       endif 
       goto 9100 
      end 
#endif

checkpoint:                    lano =    22/129/sp2.@990422.@152623 ........
contents  3. datard               subpackage
contents    3.1   datard              
c reusable
      subroutine datard (
     i Mtr , 
     o Data , N , Id )  
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       dimension Data ( MAXN * MAXCH ) 
       dimension ipick ( MAXCH * 2) , tem ( MAXCH * 2) , 
     * calib ( MAXCH * 2) 
       character*10 cbuf ( MAXCH * 2)        
       character*1 ckey 
       character*80  form 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      .......................................................
c      datard 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      datard reads Data from input unit Mtr 
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          call areachk (
     i    'datard' , 'MAXN' , MAXN , N , 1 ,
     o    ierr )
          call areachk (
     i    'datard' , 'MAXCH' , MAXCH , Id , 1 ,
     o    ierr )
       end if
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('datard', io , stio )
          call showm2 ('I',
     i    ' Reads time series data prepared in the proper form.',
     i    ' See Section 5.4.1 of CSM.')  
          call showi ('I','Mtr' ,       Mtr ,       1 , 1 , 1)
          call showr ('O','Data' ,    Data ,     N , N , Id )      
          call showi ('O','N' ,       N ,        1 , 1 , 1)       
          call showi ('O','Id' ,      Id ,       1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          nw1 = nw ('temporal' , MAXN * MAXCH * 2) - 1 
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9199  continue 
       if( mYID .eq. 0) write(6,*) 'wrong format data.'     
       call mpistop (1) 
c      ============  
 9200  continue     
       io = 'O'
       call ready (
     i Mtr )
       call rparam (
     i Mtr , 'init' , 0 , ierrx )
       call rparam (
     i Mtr , 'read' , 0 , ierr )
       call rparam (
     i Mtr , 'show' , 0 , ierrx )
       if( ierr .ne. 0) goto 9199
catch- call ipar 
       N  =  ipar ('length')
       if( N .le. 0) goto 9199 
       Id  =  ipar ('channel')
       if( Id .le. 0) goto 9199 
       ifm  =  ipar ('format')
       id2 = ( Id - 1) / 2 + 1 
       call areachk (
     i 'datard' , 'MAXCH' , MAXCH , id2 , 1 ,
     o ierr )
#ifdef AUTHOR 
       sint  =  rpar ('sampling')
       call snum ('sampling' ,  - 1 , sint , '( e15.6)')
#endif                
       if( ifm .lt. 0) then       
          ifm  =   - ifm    
       else   
          do 1499 j = 1 , Id 
             calib ( j ) = 1.d0    
 1499     continue                         
       end if 
       goto  (10 , 20)  ,  ifm     
c      -------------------       
   10  continue 
       if( ipar ('label') .eq. 1) read ( Mtr ,  * ) 
     * ( cbuf ( j ) , j = 1 , Id )
       read ( Mtr , '(A)')  form   
    1  format(20a4)     
       if( form (1:3) .eq. '(*)') then 
          if( ipar ('calibration') .eq. 1) 
     *    read ( Mtr ,  * ) ( calib ( j ) , j = 1 , Id )
       else 
          if( ipar ('calibration') .eq. 1) 
     *    read ( Mtr , form ) ( calib ( j ) , j = 1 , Id )
       end if 
       i = 0 
   15  i = i + 1 
       if( N .gt. 0 .and. i .gt. N ) goto 16 
          if( form (1:3) .eq. '(*)') then 
             read ( Mtr ,  *  , err = 16 , end = 16)
     *       ( wk ( nw1 + ( i - 1) * Id + j ) , j = 1 , Id )
          else 
             read ( Mtr , form , err = 16 , end = 16)
     *       ( wk ( nw1 + ( i - 1) * Id + j ) , j = 1 , Id )
          end if 
          goto 15 
c         =======   
   16  continue 
       N  =  i - 1 
       goto 30 
c      ======= 
   20  continue 
       do 25  j = 1 , Id 
          if( ipar ('label') .eq. 1) read ( Mtr ,  * ) cbuf ( j ) 
          read ( Mtr , '(A)')  form 
          if( ipar ('calibration') .eq. 1) 
     *    read ( Mtr ,  * ) calib ( j ) 
          if( form (1:3) .eq. '(*)') then 
             read ( Mtr ,  * ) 
     *       ( wk ( nw1 + ( i - 1) * Id + j ) , i = 1 , N )
          else 
             read ( Mtr , form ) 
     *       ( wk ( nw1 + ( i - 1) * Id + j ) , i=1 , N )
          end if 
   25  continue 
   30  continue  
       ncrip  =  N 
       if( ncrip .gt. 5) ncrip  =  5 
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
       if( mAINT .eq. 1 ) then
          write(6,*) '------ display-design -------------' , 
     *    '------------------------------------------'
          write(6,*) '|  D_window                      ' , 
     *    '                                           |'
       end if
#endif
       write(6 , '( i4 , '' - dimensional Data of length'' , i6)') 
     * Id ,  N 
       do 98 j = 1 , Id 
          if( ipar ('label') .eq. 1) then 
             write(6 , '(I2 , 1X , A , 5d12.3 , '' ....'')')
     *       j , cbuf ( j ) , 
     *       ( wk ( nw1 + ( i - 1) * Id + j ) , i = 1 , ncrip )
          else 
             write(6 , '(I2 , 5d12.3 , '' ....'')')
     *       j , ( wk ( nw1 + ( i - 1) * Id + j ),i=1 , ncrip )
          end if 
   98  continue 
catch- call ipar 
catch- call rpar 
       if( ipar ('date') .ne. 0) then 
          jj  =  rpar ('date') + ( N - 1) * 
     *    rpar ('sampling') * rpar ('unit')
          call jdate (
     i    '<--' , 
     I    iymd , itime , 
     O    jj , 0.d0 , idow )
          write(6,*) 'lastdate  = ' ,  iymd , idow 
       end if 
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
       if( mAINT .eq. 1 ) then  
          write(6,*) '|                                ' , 
     *    '                                           |'
          write(6,*) '---------------------------------' , 
     *    '--------------------------------------------' 
       end if
#endif
#ifdef ARDOCKLINK
       call keysave ('i','select components:',
     * Id , ckey , rx , ipick )
       do 1496 j = 1 , Id   
#else
       do 1496 j = 1 , Id   
          ipick ( j ) = j 
#endif
          if( ipick ( j ) .lt. 1 .or. ipick ( j ) .gt. Id ) then             
             iid  =  j - 1     
             goto 1497     
c            =========  
          end if 
c         ------
          iid = j  
 1496     continue  
 1497  continue 
#ifdef AUTHOR 
       call sarry ('pick' ,  - 1 , ipick , 1 , iid , 'i2' , 1 , Id )           
#endif 
       id0 = Id 
       Id  =  iid  
       do 95  i = 1 , N     
          do 195 j = 1 , Id 
             tem ( j )  =  wk ( nw1 + ( i - 1) * id0 +  ipick ( j )) * 
     *       calib ( ipick ( j ))
  195     continue 
          do 295 j = 1 , Id 
             Data (( j - 1) * N + i ) = tem ( j )
  295     continue 
   95  continue 
       do 199 j = 1 , Id 
          if( ipar ('label') .eq. 1) cHLAB ( j ) = cbuf ( ipick ( j ))    
  199  continue  
       goto 9100 
      end   

checkpoint:                   lano =    23/129/sp2.@990422.@152623 ........
contents    3.2   rparam              
c reusable
      subroutine rparam (
     i Mtx , Key , 
     o Ipos , Ierr )
       implicit real * 8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT 
       character*(*) Key 
       character*3 dow (7)
       character*6 buff 
       character*20 plist ( ntparam )
       dimension kind (2 , ntparam )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data kind  / 4 , 1 ,  5 , 1 ,  4 , 2 ,  4 , 2 , 
     * 9 , 3 ,  8 , 3 ,  8 , 3 ,  6 , 2 , 
     * 8 , 3 ,  4 , 1 ,  7 , 3 ,  7 , 2 ,  6 , 1 , 
     * 5 , 1 ,  11 , 1 , 3 , 3 ,  5 , 1 , 
     * 9 , 2 ,  7 , 2 ,  6 , 2 ,  7 , 1 ,  7 , 1 ,
     * 7 , 1 / 
       data plist  / 'show' , 'title' , 'date' , 'time' , 
     * 'longitude' , 'latitude' , 'altitude' , 'length' , 
     * 'sampling' , 'unit' , 'missing' , 'channel' , 'format' , 
     * 'label' , 'calibration' , 'aic' , 'arfit' , 
     * 'archannel' , 'arorder' , 'nparam' , 'arlabel' , 'reserve' ,
     * 'reserve' / 
       data dow /'sun' , 'mon' , 'tue' , 'wed' , 'thu' , 'fri' , 'sat'/ 
c      ........................................................
c      rparam 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('rparam', io , stio )
          call showm2 ('I',
     i    ' Read/writes time series parameter set.',
     i    ' See Section 5.4.1 of CSM.')
          call showi ('I','Mtx' ,    Mtx ,     1 , 1 , 1)
          call showc ('I','Key' ,   Key ,    1 , 1 , 1)      
          call showi ('O','Ipos' ,  Ipos ,   1 , 1 , 1)
          call showi ('O','Ierr' ,  Ierr ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       mT = Mtx 
       if( Key .eq. 'show')  goto 9201 
       if( Key .eq. 'write') goto 9202 
       if( Key .eq. 'distribute') goto 9203
       if( Key .eq. 'init')  goto 9204 
       if( Key .eq. 'read')  goto 9205 
       Ipos = 0 
c      ----------------------------------- 
       do 1 i = 2 , ntparam 
          ln = kind (1 , i )
          if( Key .eq. plist ( i )(1: ln )) then 
             Ipos = i - 1 
             goto 2 
c            ====== 
          end if 
    1     continue 
c         --------
          if( myid .eq. 0) write(6,*) 'rparam:' , Key , ' not found.'
    2  continue 
       goto 9100 
c      ========= 
 9201  continue 
       write(6,*) 'tparam values:'
       call fparam (
     i mT , 'show' , plist , kind , ntparam , 
     O cLIST , rLIST , iLIST , Ierr )
       goto 9100 
c      ========= 
 9202  continue 
       call fparam (
     i mT , 'write' , plist , kind , ntparam , 
     O cLIST , rLIST , iLIST , Ierr )
       goto 9100 
c      ========= 
 9203  continue 
#ifdef MPI 
       call mpi_bcast ( cLIST , ntparam * 60 , 
     * mpi_byte , 0 , MPI_COMM_WORLD , Ierr )
       call mpi_bcast ( iLIST , ntparam , 
     * MPI_INTEGER , 0 , MPI_COMM_WORLD , Ierr )
       call mpi_bcast ( rLIST , ntparam , 
     * MPI_DOUBLE_PRECISION , 0 , MPI_COMM_WORLD , Ierr )
#endif 
       goto 9100 
c      ========= 
 9204  continue 
       do 5 i = 1 , ntparam 
          iLIST ( i ) = 0 
          rLIST ( i ) = 0.d0 
          cLIST ( i ) = ' '
    5  continue 
       rLIST (8)  =  1.d0 
       iLIST (11)  =  1 
       cLIST (12)  =  'timeorder'
       iLIST (12)  =  1 
       cLIST (13)  =  'no'
       cLIST (14)  =  'no'
       cLIST (17)  =  'no'
       cLIST ( ntparam - 2)  =  'reserved key'
       cLIST ( ntparam - 1)  =  'reserved key'
       cHLAB (1) = 'ch.1'
       cHLAB (2) = 'ch.2'
       cHLAB (3) = 'ch.3'
       cHLAB (4) = 'ch.4'
       cHLAB (5) = 'ch.5'
       cHLAB (6) = 'ch.6'
       cHLAB (7) = 'ch.7'
       cHLAB (8) = 'ch.8'
       cHLAB (9) = 'ch.9'
       cHLAB (10) = 'ch.10'
       goto 9100 
c      ========= 
 9205  continue 
       read ( mT , '( a6)') buff 
       if( buff .ne. 'tparam') then 
           backspace mT 
           goto 9100 
c          ========= 
       end if 
c      ------
       call fparam (
     i mT , 'read' , plist , kind , ntparam , 
     O cLIST , rLIST , iLIST , Ierr )
       call jdate (
     i '-->' , 
     I iLIST (2) , iLIST (3) , 
     O jj , tj , jwd )
       cLIST (2) = dow ( jwd + 1)
       rLIST (2) = jj 
       rLIST (3) = tj 
       cLIST (8) = cLIST (9)
       rLIST (9) = 1.d0 
       if( cLIST (9) .eq. 'year')  rLIST (9) = 365.25d0 
       if( cLIST (9) .eq. 'month') rLIST (9) = 30.4375d0 
       if( cLIST (9) .eq. 'week')  rLIST (9) = 7.d0 
       if( cLIST (9) .eq. 'day')   rLIST (9) = 1.d0 
       if( cLIST (9) .eq. 'hour')  rLIST (9) = 1.d0/24.d0 
       if( cLIST (9) .eq. 'minute') rLIST (9)= 1.d0/24.d0/60.d0 
       if( cLIST (9) .eq. 'second') rLIST (9)= 1.d0/24.d0/60.d0/60.d0
       if( rLIST (10) .ne. 0.d0) iLIST (10) = 1 
       if( cLIST (12)(1:7) .eq. 'channel') iLIST (12) = 2 
       if( cLIST (12)(1:4) .eq. 'time')    iLIST (12) = 1 
       if( cLIST (13)(1:3) .eq. 'yes')     iLIST (13)  =  1 
       if( cLIST (13)(1:2) .eq. 'no')      iLIST (13)  =  0 
       if( cLIST (14)(1:3) .eq. 'yes')     iLIST (14)  =  1 
       if( cLIST (14)(1:2) .eq. 'no')      iLIST (14)  =  0 
       if( cLIST (20)(1:3) .eq. 'yes')     iLIST (20)  =  1 
       if( cLIST (20)(1:2) .eq. 'no')      iLIST (20)  =  0 
       goto 9100 
      end 

checkpoint:                  lano =    24/129/sp2.@990422.@152623 ........
contents    3.3   fparam              
c reusable
      subroutine fparam (
     i Mt , Cmd , Plist , Kind , Ntparam , 
     O Clist , Rlist , Ilist , Ierr )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*(*) Cmd , Clist ( Ntparam ) ,  Plist ( Ntparam )
       dimension Kind (2 , 1) , Rlist ( Ntparam ) , Ilist ( Ntparam )
       character*20 key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      fparam 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('fparam', io , stio )
          call showm ('I',
     i    ' Read/writes general parameter set.')
          call showi ('I','Mt' ,      Mt ,         1 , 1 , 1)
          call showc ('I','Cmd' ,     Cmd ,        1 , 1 , 1)      
          call showc ('I','Plist' ,   Plist ,      1 , 1 , Ntparam )
          call showi ('I','Kind' ,    Kind ,       1 , 1 , Ntparam * 2)      
          call showi ('I','Ntparam' , Ntparam ,    1 , 1 , 1)
          call showc ('A','Clist' ,   Clist ,      1 , 1 , Ntparam )      
          call showr ('A','Rlist' ,   Rlist ,      1 , 1 , Ntparam )
          call showi ('A','Ilist' ,   Ilist ,      1 , 1 , Ntparam )
          call showi ('O','Ierr'  ,   Ierr  ,      1 , 1 , 1 )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9199  continue 
          Ierr = 1 
          goto 9100 
 9200  continue     
       io = 'O'
       Ierr = 0 
       if( Cmd .eq. 'write') goto 9202  
       if( Cmd .eq. 'show')  goto 9203
c      ------------------------------
c      if( Cmd .eq. 'read')    
    1  read ( Mt , '( a )' , err = 9199 , end = 9199 ) key 
       if( key (1:3) .eq. 'end') goto 9100 
c      --------------------------------- 
       j = 0 
    2  j = j + 1 
       if( j .gt. Ntparam ) goto 1 
c      ------------------------- 
       ln = Kind (1 , j )
       if( key (1:ln ) .ne. Plist ( j )(1:ln )) goto 2 
c      ----------------------------------------- 
       if( j .gt. 1) then 
          ieq = 0 
          key (20:20) = 'x' 
          do 19 i = 1 , 20 
             if( ieq .eq. 1 .and. key ( i:i ) .ne. ' ') then 
                ipos  =  i - 1 
                call gparam (
     i          Mt , ipos , Kind (2 , j ) , 
     o          Clist ( j - 1) , Rlist ( j - 1) , Ilist ( j - 1))
                goto 1 
c               ====== 
             end if 
c            ------
             if( key ( i:i ) .eq. '=') ieq  =  1 
   19     continue    
       else 
c      ----
          write(6 , 60)
   60     format(1x , 'present setting')
          do 100 k = 1 , Ntparam - 1 
             ln = Kind (1 , k + 1)
             if( Kind (2 , k + 1) .eq. 3) 
     *       write(6 , 61) k , Plist ( k + 1)(1:ln ) , Rlist ( k )
   61        format(1x , i2 , ':' , a , ' = ' , d13.6)
             if( Kind (2 , k + 1) .eq. 2) 
     *       write(6 , 62) k , Plist ( k + 1)(1:ln ) , Ilist ( k )
   62        format(1x , i2 , ':' , a , ' = ' , i10)
             if( Kind (2 , k + 1) .eq. 1) 
     *       write(6 , 63) k , Plist ( k + 1)(1:ln ) , Clist ( k )
   63        format(1x , i2 , ':' , a , ' = ' , a )
  100     continue 
       end if 
       goto 1 
c      ====== 
 9202  continue 
       write( Mt , 960)
  960  format('tparam')
       do 8100 k = 1 , Ntparam - 1 
          ln = Kind (1 , k + 1)
          if( Kind (2 , k + 1) .eq. 3) 
     *    write( Mt , 961) Plist ( k + 1)(1:ln ) , Rlist ( k )
  961     format( a , ' = ' , d15.8)
          if( Kind (2 , k + 1) .eq. 2) 
     *    write( Mt , 962) Plist ( k + 1)(1:ln ) , Ilist ( k )
  962     format( a , ' = ' , i10)
          if( Kind (2 , k + 1) .eq. 1) 
     *    write( Mt , 963) Plist ( k + 1)(1:ln ) , Clist ( k )
  963     format( a , ' = ' , a )
 8100  continue 
       write( Mt , '(''end'')')
       goto 9100 
c      ========= 
 9203  continue 
       do 8101 k = 1 , Ntparam - 1 
          ln = Kind (1 , k + 1)
          if( Kind (2 , k + 1) .eq. 3) 
     *    write(6 , 61) k , Plist ( k + 1)(1:ln ) , Rlist ( k )
          if( Kind (2 , k + 1) .eq. 2)
     *    write(6 , 62) k , Plist ( k + 1)(1:ln ) , Ilist ( k )
          if( Kind (2 , k + 1) .eq. 1) 
     *    write(6 , 63) k , Plist ( k + 1)(1:ln ) , Clist ( k )
 8101  continue 
       goto 9100 
      end 

checkpoint:                 lano =    25/129/sp2.@990422.@152623 ........
contents    3.4   gparam              
c reusable
      subroutine gparam (
     i Mt , Ipos , Kind , 
     o Clist , Rlist , Ilist )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*10 xform (21) , yform (3)
       character*60 Clist , rform 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data yform  / ' , a )' , ' , i20)' , ' , f20.0)' / 
       data xform  / '(1x','(2x','(3x','(4x','(5x','(6x','(7x',
     * '(8x','(9x','(10x','(11x','(12x','(13x','(14x',
     * '(15x','(16x','(17x','(18x','(19x','(20x','(21x' / 
c      ........................................................
c      gparam 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gparam', io , stio )
          call showm ('I',
     i    ' Read/writes an item of parameter set.')
          call showi ('I','Mt' ,      Mt ,         1 , 1 , 1)
          call showi ('I','Ipos' ,    Ipos ,       1 , 1 , 1)      
          call showi ('I','kind' ,    Kind ,       1 , 1 , 1)      
          call showc ('O','Clist' ,   Clist ,      1 , 1 , 1)      
          call showr ('O','Rlist' ,   Rlist ,      1 , 1 , 6)
          call showi ('O','Ilist' ,   Ilist ,      1 , 1 , 6)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue       
       io = 'O'
       backspace Mt 
       rform = xform ( Ipos ) // yform ( Kind )
       if( Kind .eq. 3) read ( Mt , rform ) Rlist 
       if( Kind .eq. 2) read ( Mt , rform ) Ilist 
       if( Kind .eq. 1) read ( Mt , rform ) Clist 
       goto 9100 
      end 

checkpoint:                lano =    26/129/sp2.@990422.@152623 ........
contents    3.5   jdate               
c reusable
      subroutine jdate (
     i Ymd2date , 
     I Ymd , Time , 
     O Date , Atime , 
     o Dayoweek )
       implicit integer * 4 ( a - z )
#include "ardock.env"
       character*(*) Ymd2date  
       real * 8 Atime , ttime 
       dimension mon (13)
       character*1  io 
#ifdef MODIFIER
       character*1 stio , viv , vov 
       data inisub /0/
#endif  
       data mon  / 0,31,61,92,122,153,184,214,245,275,306,337,366 / 
c      ........................................................
c      jdate 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          Dayoweek  =  mod ( Date + 2 , 7)
          if( Dayoweek .lt. 0) Dayoweek = Dayoweek + 7 
       end if
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('jdate', io , stio )
          call showm2 ('I',
     i    ' Converts calendar data to the day count from',
     i    ' Jun. 1. 1601.AD., and vice versa.')
          call showc ('I','Ymd2date' ,  Ymd2date ,   1 , 1 , 1)
          if( Ymd2date .eq. '-->') then
             viv = 'I'
             vov = 'O'
          else
             viv = 'O'
             vov = 'I'
          end if
          call showi (viv,'Ymd' ,       Ymd ,        1 , 1 , 1)      
          call showi (viv,'Time' ,      Time ,       1 , 1 , 1)
          call showi (vov,'Date' ,      Date ,       1 , 1 , 1)
          call showr (vov,'Atime' ,     Atime ,      1 , 1 , 1)
          call showi ('O','Dayoweek' ,Dayoweek ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Ymd2date .ne. '-->') goto 9201   
c      --------------------------------------
       year  =  Ymd / 10000 
       day  =  Ymd - year * 10000 
       month  =  day / 100 
       day  =  day - month * 100 
       hour  =  Time / 10000 
       second  =  Time - hour * 10000 
       minute  =  second / 100 
       second  =  second - minute * 100 
       Atime  =  hour + minute / 60.d0 + second / 3600.d0 
       Atime  =  Atime  / 24.d0 
       nm  =  month - 2 
       ny  =  year - 1600 
       if( nm .le. 0) then 
          nm  =  nm + 12 
          ny  =  ny - 1 
       end if 
       nl  =  ny / 4 
       nll  =  ny / 100 
       nlll  =  ny / 400 
       Date  =  ny * 365 + nl - nll + nlll + mon ( nm ) + day 
       goto 9100 
c      ========= 
 9201  continue 
       jd = Date 
       j400  =  ( jd - 1) / 146097 
       jd  =  jd - j400 * 146097 
       j100  =  ( jd - 1) / 36524 
       if( j100 .eq. 4) j100 = 3
       jd  =  jd - j100 * 36524 
       j4  =  ( jd - 1) / 1461 
       jd  =  jd - j4 * 1461 
       j1  =  ( jd - 1) / 365 
       if( j1 .eq. 4) j1  =  3
       jd  =  jd - j1 * 365 
       year  =  1600 + j1 + j4 * 4 + j100 * 100 + j400 * 400 
       do 1 j = 1 , 12 
          if( jd .le. mon ( j + 1)) then 
             month = j + 2 
             day  =  jd - mon ( j )
             if( month .gt. 12) then 
                month  =  month - 12 
                year  =  year + 1 
             end if 
             goto 9 
c             ====== 
          end if 
c         ------
    1     continue 
    9  continue 
       Ymd  =  year * 10000 + month * 100 + day 
       ttime  =  Atime * 24.d0 
       hour  =  ttime 
       ttime  =  ttime - hour 
       ttime  =  ttime * 60.d0 
       minute  =  ttime 
       ttime  =  ttime - minute 
       second  =  ttime * 60.d0 
       Time  =  hour * 10000 + minute * 100 + second 
       goto 9100 
      end    

checkpoint:               lano =    27/129/sp2.@990422.@152623 ........
contents    3.6   cpar                
c reusable 
      character*(*) function cpar ( Key )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      cpar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('cpar', io , stio )
          call showm2 ('I',
     i    ' Recalls c-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' , Key , 1 , 1 , 1)
          call showc ('O','Cpar' , Cpar , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       Cpar = cLIST ( ipos )
       goto 9100 
      end 

checkpoint:              lano =    28/129/sp2.@990422.@152623 ........
contents    3.7   ipar                
c reusable
      function ipar ( Key )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      ipar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('ipar', io , stio )
          call showm2 ('I',
     i    ' Recalls i-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' , Key , 1 , 1 , 1)
          call showi ('O','Ipar' , Ipar , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       Ipar = ilist ( ipos )
       goto 9100 
      end 

checkpoint:             lano =    29/129/sp2.@990422.@152623 ........
contents    3.8   rpar                
c reusable
      function rpar ( Key )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      rpar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('rpar', io , stio )
          call showm2 ('I',
     i    ' Recalls r-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' ,  Key ,  1 , 1 , 1)
          call showr ('O','Rpar' , Rpar , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       Rpar = rlist ( ipos )
       goto 9100 
      end 

checkpoint:            lano =    30/129/sp2.@990422.@152623 ........
contents    3.9   clab                
c reusable
      character*(*) function clab ( Key )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       character*1  io 
c      ........................................................
c      clab 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Recalls the label of a channel. See Section \refmy{DATAFILE}.
       io = 'I'
 9100  continue 
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Clab = cHLAB ( Key )
       goto 9100 
      end 

checkpoint:           lano =    31/129/sp2.@990422.@152623 ........
contents    3.10  cset                
c reusable
      subroutine cset (
     i Key , Cpar )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key , Cpar 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      cset 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('cset', io , stio )
          call showm2 ('I',
     i    ' Sets c-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' ,  Key ,  1 , 1 , 1)
          call showc ('I','Cpar' , Cpar , 1 , 1 , 1)
          if( io .eq. 'O') then 
             write(6 , '('' tparam '' , A , '' is set equal to '' ,           '
     *       A12)') Key , Cpar                                                '
          end if
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       if( ipos .ne. 0) cLIST ( ipos ) = Cpar 
       goto 9100 
      end 

checkpoint:          lano =    32/129/sp2.@990422.@152623 ........
contents    3.11  iset                
c reusable 
      subroutine iset (
     i Key , Ipar )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      iset 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('iset', io , stio )
          call showm2 ('I',
     i    ' Sets i-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' ,  Key ,  1 , 1 , 1)
          call showi ('I','Ipar' , Ipar , 1 , 1 , 1)
          if( io .eq. 'O') then
             write(6 , '('' tparam '' , A , '' is set equal to '' ,          '
     *       I12)') Key , Ipar                                               '
          end if
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       if( ipos .ne. 0) ilist ( ipos ) = Ipar 
       goto 9100 
      end 

checkpoint:         lano =    33/129/sp2.@990422.@152623 ........
contents    3.12  rset                
c reusable
      subroutine rset (
     i Key , Rpar )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )        
       common  /ctparam/  cLIST , cHLAB 
       common  /dtparam/  rLIST ( ntparam ) , iLIST ( ntparam ) , mT  
       character*(*) Key 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      rset 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue
#ifdef MODIFIER
       myself = 9      
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('rset', io , stio )
          call showm2 ('I',
     i    ' Sets r-type time series parameter.',
     i    ' See Section 5.4.1 of CSM.')
          call showc ('I','Key' ,  Key , 1 , 1 , 1)
          call showr ('I','Rpar' , Rpar ,1 , 1 , 1)
          if( io .eq. 'O') then
             write(6 , '('' tparam '' , A , '' is set equal to '' ,           '
     *       D12.5)') Key , Rpar                                              '
          end if 
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call rparam (
     i mt , Key , 
     o ipos , ierr )
       if( ipos .ne. 0) rlist ( ipos ) = Rpar 
       goto 9100 
      end 

checkpoint:        lano =    34/129/sp2.@990422.@152623 ........
contents  4. arfit                subpackage
contents    4.1   arfit               
c reusable
      subroutine arfit (
     i Data , Ndata , Kch , Lagmax , Mean , 
     o Aicmin , Var , Ar , Poly , Lagopt , Indexm )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       character*7 Cmd , cyw  
       dimension Data ( Ndata , Kch )
       dimension Ar ( Kch , Kch , 1) , Var ( Kch , Kch ), 
     * Indexm ( Kch , Kch ), Poly ( Kch , 5)
       character*1 ckey   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ........................................................
c      arfit 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          iw0 = iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9  
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arfit', io , stio )
          call showm ('I',
     i    ' Reserves work area and calls  arfitw.')
          call showr ('I','Data' ,  Data ,    Ndata , Ndata , Kch )
          call showi ('I','Ndata' , Ndata ,   1 , 1 , 1)    
          call showi ('I','Kch' ,   Kch ,     1 , 1 , 1)
          call showi ('I','Lagmax' ,Lagmax ,  1 , 1 , 1)
          call showi ('I','Mean' ,  Mean ,    1 , 1 , 1)
          call showr ('O','Aicmin', Aicmin ,  1 , 1 , 1)
          call showr ('O','Var' ,   Var ,     Kch , Kch , Kch )
          call showr ('O','Ar' ,    Ar ,      Kch , Kch , Kch )    
          call showr ('O','Poly' ,  Poly ,    Kch , Mean , Mean )    
          call showi ('O','Lagopt', Lagopt ,  1 , 1 , 1)    
          call showi ('O','Indexm', Indexm ,  Kch , Kch , Kch )
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          iw0 = iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       cyw = ' ' 
       Cmd = 'mar' 
#ifdef ARDOCKLINK
#ifdef AUTHOR
       if( mAINT .eq. 1) then
          call keympi ('c','SAR: a?m?n?x?' , 0 , ckey , rx , icho )
          if( ckey .eq. 'm') Cmd = 'subset' 
          if( ckey .eq. 'a') Cmd = 'asubset' 
          if( ckey .eq. 'x') then 
             call keympi ('c','MULMAR?' , 0 , ckey , rx , icho )
             if( ckey .eq. 'y') Cmd = 'mulmar' 
             call keympi ('c','YW?' , 0 , ckey , rx , icho )
             if( ckey .eq. 'y') cyw = 'yw' 
          end if
       else
          call keympi ('c','SAR: a?m?n?' , 0 , ckey , rx , icho )
          if( ckey .eq. 'm') Cmd = 'subset' 
          if( ckey .eq. 'a') Cmd = 'asubset' 
       end if
#else
          call keympi ('c','SAR: a?m?n?' , 0 , ckey , rx , icho )
          if( ckey .eq. 'm') Cmd = 'subset' 
          if( ckey .eq. 'a') Cmd = 'asubset' 
#endif
#else
       Cmd = 'asubset'
#endif
       nx = Ndata + Lagmax 
       mx = Mean + ( Lagmax + 1) * Kch 
       call arfitw (
     i Cmd , cyw , Data , Ndata , Kch , Lagmax , Mean , nx , mx , 
     o Aicmin , Var , Ar , Poly, Lagopt , Indexm , 
     w wk ( nw ('hh' , nx * mx )) , wk ( nw ('parl' , mx * Kch )) , 
     w wk ( nw ('save' , nx )) , wk ( nw ('resid' , nx )) ,
     w iwk ( iw ('indexv' , mx )), wk ( nw ('str' , mx * Kch )))
       goto 9100 
      end 


checkpoint:       lano =    35/129/sp2.@990422.@152623 ........
contents    4.2   arfitw              
c reusable
      subroutine arfitw (
     i Cmd , Cyw , Data , Ndata , Kch , Lagmax , Mean , Nx , Mx , 
     o Aicmin , Var , Ar , Poly , Lag , Indexm ,
     w hh , parl , save , d0 , longindex , str )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       character*(*) Cyw ,  Cmd 
       dimension Data ( Ndata , 1)
       dimension Ar ( Kch , Kch , 1) , Var ( Kch , Kch ),
     * Indexm ( Kch , Kch )
       dimension hh ( Nx , Mx ) , parl ( Mx , Kch ) ,
     * save ( Nx ) , d0 ( Nx ) , Poly ( Kch ,5) ,
     * longindex ( Mx ) , str ( Mx , Kch )         
       dimension con ( MAXCH , MAXCH ) 
       dimension indexo ( MAXCH , MAXCH )
       character*12 clab   
       character*1 ckey , action   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
       data init / 1 /, rlim /0.d0/
c      ........................................................
c      arfitw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed. 
       call areachk (
     i 'arfitw','{',0,0,0,
     o ierr )
       call mpistop ( ierr )
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arfitw', io , stio )
          call showm2 ('I',
     i    ' Fits MAR/SAR/PAR model.',
     i    ' See Sections 2.2, 2.4 and 4.1 of CSM')
          call showc ('I','Cmd' ,   Cmd ,      1 , 1 , 1)
          call showc ('I','Cyw' ,   Cyw ,      1 , 1 , 1)
          call showr ('I','Data' ,  Data ,     Ndata , Ndata , Kch )
          call showi ('I','Ndata' , Ndata ,    1 , 1 , 1)    
          call showi ('I','Kch' ,   Kch ,      1 , 1 , 1)
          call showi ('I','Lagmax' ,Lagmax ,   1 , 1 , 1)
          call showi ('I','Mean' ,  Mean ,     1 , 1 , 1)
          call showi ('I','Nx' ,    Nx ,       1 , 1 , 1)
          call showi ('I','Mx' ,    Mx ,       1 , 1 , 1)
          call showi ('A','Indexm', Indexm ,   Kch , Kch , Kch )
          call showr ('O','Aicmin', Aicmin ,   1 , 1 , 1)
          call showr ('O','Var' ,   Var ,      Kch , Kch , Kch )
          call showr ('O','Ar' ,    Ar ,       Kch , Kch , Kch )    
          call showi ('O','Lag' ,   Lag ,      1 , 1 , 1)    
          call showw ('hh' ,    Nx ,       Mx )
          call showw ('parl' ,   Mx ,       Kch )
          call showw ('d' ,     Nx ,       1)
          call showw ('d0' ,    Nx ,       1)
          call showw ('b0' ,    Kch ,      Kch )
          call showw ('b1' ,    Kch ,      Kch )
          call showw ('indexv', Mx ,       1)
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
catch-    call rpar 
          rlim  =  rpar ('missing')
       end if 
       mfkf = Mx
       nhh = Ndata 
       if( Cyw .eq. 'yw') then        
          call build (
     i    Data , rlim , 1 , Ndata , Kch , Lagmax , Nx , Mean , 
     o    hh , nhh )
          call hushld (
     i    Nx , nhh + Lagmax , mfkf , 
     a    hh )
       else 
          call build (
     i    Data , rlim , 0 , Ndata , Kch , Lagmax , Nx , Mean , 
     o    hh , nhh )
          call hushld (
     i    Nx , nhh , mfkf , 
     a    hh )
       end if 
       do 1200 k = 1 , Kch 
       do 1201 j = 1, Mx 
          str ( j , k ) = Hh ( j , Mean + Lagmax * Kch + k ) 
 1201  continue 
 1200  continue 
       bn  =  nhh 
       an = 1.d0 / bn   
       if( Cmd .ne. 'mulmar' ) then
          call arorder (
     i    an , bn , hh , Kch , Lagmax , Mean , Nx , Mx ,   
     o    maice , Aicmin ,
     w    save , d0 , longindex , str )
       end if
 6669  continue 
       Lag = 0 
       if( Cmd .eq. 'mar' ) then 
          Lag = maice  
          call marfit (
     i    an , bn , hh , Kch , Lagmax , Mean , Nx , Mx , maice ,
     o    Aicmin , parl ,
     w    longindex )
          call maskrs (
     i    MAXCH , 
     o    indexo )
       end if
       if( Cmd .eq. 'subset' .or. Cmd .eq. 'asubset') then
          Lag = maice 
          if(myid .eq. 0) then 
             write(6,'( '' lag = '',i3,                                       '
     *       ''  AIC = '',f10.2,/)') Maice , Aicmin                           '
          end if 
          call maskrs (
     i    Kch , 
     o    indexm )
       end if
 6666  continue
       if( Cmd .eq. 'subset' .or. Cmd .eq. 'asubset') then
          con (1,1) = -12345.678                         
          action = 'a'
#ifdef    ARDOCKLINK
          if( Cmd .eq. 'subset') then
             write(6,*) 'subset index matrix'
             call subwin2 ( 
     i       Kch , Indexm ) 
             call click3 (
     i       Kch ,
     a       Indexm ,
     o       action )
          end if
#endif
          call sarfit (
     i    action ,
     i    an , bn , hh , Kch , Lagmax , Mean , Nx , Mx , maice ,     
     a    Indexm ,
     o    Aicmin , parl , con ,  
     w    save , d0 , longindex )
       end if 
#ifdef AUTHOR
       if( Cmd .eq. 'mulmar' .and. mAINT .eq. 1) then  
          call maskrs (
     i    Kch , 
     o    Indexm )
          call arfitq (
     i    Cmd , Cyw , 
     i    an , bn , hh , Kch , Lagmax , Mean , Nx , Mx , maice , 
     a    Indexm ,
     o    Aicmin , parl , con , Lag , 
     w    save , d0 , longindex )
       end if
#endif
       if( myid .eq. 0) then 
          write(6,*)
          write(6,*) 'summary'
          write(6 , '( '' lag = '' , i3 , ''  AIC = '' , f10.2)') lag ,
     *    Aicmin 
       end if 
       if( myid .eq. 0 .and. 
     *    ( Cmd .eq. 'subset' .or. Cmd .eq. 'asubset' .or. 
     *    Cmd .eq. 'mulmar')) then 
          write(6,*)   
          write(6,*)  '        system structure' 
          write(6,*)
          do 139 i = 1 , Kch 
             write(6 , '(1x , a ,15i2)') 
     *       clab ( i ),( Indexm ( i , j ), j = 1 , Kch )
 139      continue                    
          do 128 i = 1 , Kch   
          do 129 j = 1 , Kch 
             con ( i , j )  =  con ( i , j )  *  
     *       ( Indexm ( i , j ) * 2.d0 - 1.d0)
  129     continue                         
  128     continue 
          if( con (1,1) .ne. -12345.678 ) then                        
             write(6,*)   
             write(6,*)  '    causality degree matrix'   
             do 149 i = 1 , Kch 
                write(6 , '(1x , a ,10f7.1)') clab ( i ),
     *          ( con ( i , j ) , j = 1 , Kch )   
 149         continue 
          end if                      
       end if 
#ifdef ARDOCKLINK
       if( Cmd .eq. 'subset') then
          call keympi ('c','OK?' , 0, ckey , rx , ix )
          if( ckey .ne. 'y' ) then 
             do 1202 k = 1 , Kch 
             do 1203 j = 1, Mx 
                Hh ( j , Mean + Lagmax * Kch + k ) = str ( j , k ) 
 1203        continue 
 1202        continue 
             goto 6666 
          end if
c         ------
       end if 
#endif
       do 882 j = 1 , Kch 
       do 888 k = 1 , Kch 
       do 881 m = 1 , lag 
          Ar ( j , k , m )  =  
     *    parl ( Mean + ( m - 1) * Kch + k , j )     
  881  continue 
  888  continue 
  882  continue 
       do 1122 j = 1 , Kch 
corrected2000.11.21 corrections are made by M.I.
       do 1123 k = 1 , Kch 
          if( k .ge. j ) then 
             Var ( k , j ) = parl ( Mean + Lagmax * Kch + j ,  k )  
          else
             Var ( k , j ) = 0.d0  
          end if
 1123  continue 
 1124  continue
 1122  continue 
       call posmat (
     i 'make' , Kch , Kch , 
     a Var , 
     o det , ierr ) 
       do 1130 j = 1 , Kch 
       do 1131 k = 1 , Mean
          Poly ( j , k ) = parl ( k , j)           
 1131  continue
 1130  continue 
       goto 9100 
      end 

checkpoint:      lano =    36/129/sp2.@990422.@152623 ........
contents    4.3   marfit              
c reusable
      subroutine marfit (
     i An , Bn , Hh , Kch , Lagmax , Mean , Nx , Mx , Maice , 
     o Aicmin , Parl , 
     w longindex )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension Hh ( Nx , Mx ) , Parl ( Mx , Kch ) , longindex ( Mx )        
       dimension indexvp ( MAXCH )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data indexvp / MAXCH *1/
       data init / 1 /, pi /0.d0/, pi2 /0.d0/
c      ........................................................
c      marfit 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('marfit', io , stio )
          call showm ('I',
     i    ' Least squares method for MAR/PAR model(2.15) fitting.')
          call showi ('I','Kch' ,   Kch ,    1 , 1 , 1)
          call showi ('I','Lagmax' ,Lagmax , 1 , 1 , 1)
          call showi ('I','Mean' ,  Mean ,   1 , 1 , 1)
          call showi ('I','Nx' ,    Nx ,     1 , 1 , 1)
          call showi ('I','Mx' ,    Mx ,     1 , 1 , 1)
          call showi ('I','Maice',  Maice ,  1 , 1 , 1)    
          call showr ('I','Hh' ,    Hh ,     Nx , Mx , Mx )
          call showr ('I','An' ,    An ,     1 , 1 , 1)    
          call showr ('I','Bn' ,    Bn ,     1 , 1 , 1)    
          call showr ('O','Aicmin', Aicmin , 1 , 1 , 1)
          call showr ('O','Parl',   Parl ,   Mx , Mx , Kch )   
          call showw ('d' ,     Nx ,      1)
          call showw ('d0' ,    Nx ,      1)
          call showw ('indexv', Mx ,      1)
          call showw ('indexo', Mx ,     1)
          call showw ('con',    Kch ,     Kch )
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          pi  =  atan2 (0.d0 ,  - 1.d0) 
          pi2 = dlog ( pi * 2.d0)
       end if 
       aic  = 0.d0 
       do 900 kk = 1 , Kch 
          mmkk =  Mean + Lagmax * Kch + kk - 1 
          call indexset (
     i    indexvp , Maice , Kch , Lagmax , kk , Mean , 
     o    longindex , npar , id )
          call sssolver (
     i    mmkk , Nx , 1 , longindex , 
     a    Hh , 
     o    Parl (1 , kk ) , sqez )
          sqeo = An * sqez 
          aick  =  Bn * ( pi2 + dlog ( sqeo ) + 1) + 2.d0 * npar 
          Parl ( mmkk + 1 , kk ) = dsqrt ( sqeo ) 
          aic  =  aic  + aick 
  900  continue
       Aicmin  =   aic 
       goto 9100 
      end 

checkpoint:     lano =    37/129/sp2.@990422.@152623 ........
contents    4.4   sarfit              
c reusable
      subroutine sarfit (
     i Action ,
     i An , Bn , Hh , Kch , Lagmax , Mean ,
     i Nx , Mx , Maice , 
     a Indexm ,   
     o Aicmin , Parl , Con , 
     w save , resid , longindex )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension Indexm ( Kch , Kch )  
       dimension Hh ( Nx , Mx ) , Parl ( Mx , Kch ) ,
     * save ( Nx ) , resid ( Nx ) ,
     * longindex ( Mx )          
       dimension a (( MAXLAG + 1) * MAXCH ) , con ( MAXCH , MAXCH ) 
       dimension indextem ( MAXCH )
       dimension list (1024) , aicl (1024) , indexopt ( MAXCH )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif
       character*1 Action  
       data init / 1 /, pi /0.d0/, pi2 /0.d0/
c      ........................................................
c      sarfit 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('sarfit', io , stio )
          call showm2 ('I',
     i    ' SAR model(2.23) fit and index matrix search.',
     i    ' The causality degree matrix (5.80) is shown.')
          call showc ('I','Action',  Action , 1 , 1 , 1)    
          call showr ('I','An' ,     An ,     1 , 1 , 1)    
          call showr ('I','Bn' ,     Bn ,     1 , 1 , 1)    
          call showi ('I','Kch' ,    Kch ,    1 , 1 , 1)
          call showi ('I','Lagmax' , Lagmax , 1 , 1 , 1)
          call showi ('I','Mean' ,   Mean ,   1 , 1 , 1)
          call showi ('I','Indexm',  Indexm , Kch , Kch ,Kch )
          call showi ('I','Nx' ,     Nx ,     1 , 1 , 1)
          call showi ('I','Mx' ,     Mx ,     1 , 1 , 1)
          call showr ('I','Hh ' ,    Hh ,     Nx , Mx , Mx )
          call showr ('O','Aicmin' , Aicmin , 1 , 1 , 1)
          call showr ('O','Parl' ,   Parl ,   Mx, Mx, Kch )
          call showi ('O','Maice' ,  Maice ,  1 , 1 , 1)    
          call showw ('d' ,      Nx ,        1)
          call showw ('d0' ,     Nx ,        1)
          call showw ('indexv' , Mx ,        1)
          call showw ('Indexm', Mx ,     1)
          call showw ('con',    Kch ,     Kch )
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          pi  =  atan2 (0.d0 ,  - 1.d0) 
          pi2 = dlog ( pi * 2.d0)
       end if 
       mfkf = Mx 
       aic  = 0.d0 
       do 900 kk = 1 , Kch 
          if( myid .eq. 0) then 
             write(6,'(''effective variable search for '',                  '
     *       i2,'' - th variable'')') kk                                    '
             write(6 , '(''         AIC           #param  Indexv'')')
          end if 
          mmkk = Mean + Lagmax * Kch + kk - 1 
          do 901 l = 1 , mfkf 
             save ( l ) = Hh ( l , mmkk + 1)
  901     continue 
          do 200 k = 1 , Kch 
             if( Action .eq. 'a') then 
                indexopt ( k ) = 1 
             else 
                indexopt ( k ) = Indexm ( kk , k )
             end if   
  200     continue 
          kfp2 = 2 ** Kch 
          do 201 k = 1 , kfp2  
             list ( k ) = 0 
  201     continue 
          call indexset (
     i    indexopt , Maice , Kch , Lagmax , kk , Mean , 
     o    longindex , npar , id )
          call sssolver (
     i    mmkk , Nx , 1 , longindex , 
     a    Hh , 
     o    Parl (1 , kk ) , sqez )
          sqeo = An * sqez 
          aick  =  Bn * ( pi2 + dlog ( sqeo ) + 1) + 2.d0 * npar 
          nparo = npar 
          list ( id ) = 1 
          aicl ( id ) = aick 
          do 9003 l = 1 , mfkf 
             resid ( l ) = Hh ( l , mmkk + 1)
 9003     continue 
  800     new = 0 
          if( myid .eq. 0)
     *    write(6 , 1801) ' ' , aick , nparo ,
     *    ( Indexm ( kk , kkk ) , kkk = 1 , Kch )
 1801     format( a , f10.2 , 15x , i3 , 3x , 10i1)
  801     format( a , f10.2 , 8x , i3 , 3x , 10i1)
          if( Action .ne. 'a') then
             new = 1 
             goto 606 
          end if
          do 600 it1 = 1 , Kch 
             do 601 it2 = 1 , Kch 
                if( it2 .ne. it1) then 
                   indextem ( it2) = Indexm ( kk , it2) 
                else     
                   indextem ( it2) = 1 - Indexm ( kk , it2)     
                end if 
  601        continue 
             call indexset (
     i       indextem , Maice , Kch , Lagmax , kk , Mean , 
     o       longindex , npar , id ) 
             if( list ( id ) .eq.  1) then 
                aictem  =  aicl ( id )
                con ( kk , it1)  =  aictem - aick 
             else 
                do 9002 l = 1 , mfkf 
                   Hh ( l , mmkk + 1) =  save ( l ) 
 9002           continue 
                call sssolver (
     i          mmkk , Nx , 1 , longindex , 
     a          Hh , 
     o          a , sqez )
                aictem  =  Bn  * ( pi2 + dlog ( sqez  *  An ) + 1)  + 
     *          2.d0 *  npar 
                if( myid .eq. 0) 
     *          write(6 , 801) '       :' , aictem ,  npar , 
     *          ( indextem ( kkk ) , kkk = 1 , Kch )
                list ( id )  =  1 
                aicl ( id )  =  aictem 
                new = 1 
                con ( kk , it1)  =  aictem - aick 
                if( aictem .le. aick ) then 
                   aick = aictem 
                   sqeo = sqez * An   
                   nparo = npar 
                   do 903 l = 1 , mfkf 
                      Parl ( l , kk ) = a ( l ) 
                      resid ( l )  =  Hh ( l , mmkk + 1) 
  903              continue 
                   do 1496 kkk = 1 , Kch 
                      indexopt ( kkk ) = indextem ( kkk ) 
 1496              continue 
                end if   
             end if  
  600     continue 
  606     continue 
          if( new .eq. 1 ) then 
             Parl ( mmkk + 1 , kk ) = dsqrt ( sqeo ) 
             do 1498 kkk = 1 , Kch  
                Indexm ( kk , kkk ) = indexopt ( kkk )
 1498        continue 
             if( Action .eq. 'a') goto 800 
c            ----------------------------- 
          end if     
c         ------
          aic  =  aic  + aick 
          do 904 l = 1 , mfkf  
             Hh ( l , mmkk + 1)  =  resid ( l )
  904     continue 
  900  continue
       Aicmin  =   aic 
       goto 9100 
      end 

checkpoint:    lano =    38/129/sp2.@990422.@152623 ........
contents    4.5   build               
c reusable
      subroutine build (
     i Data , Rlim , Mfpec , Ndata , Kch , Lagmax , Nx , Mean , 
     o Hh , Nfix )  
       implicit real * 8 ( a-h , o-z )     
#include "ardock.env"
       dimension Hh ( Nx , MAXLAG * MAXCH )
       dimension Data ( Ndata , Kch ) 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      build        
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('build', io , stio )
          call showm ('I',
     i    ' Builds up linear equation matrix(4.67) of CSM.')
          call showr ('I','Data' ,  Data ,  Ndata , Ndata , Kch )
          call showr ('I','Rlim' ,  Rlim ,  1 , 1 , 1)
          call showi ('I','Mfpec',  Mfpec , 1 , 1 , 1)
          call showi ('I','Ndata',  Ndata , 1 , 1 , 1)
          call showi ('I','Kch' ,   Kch ,   1 , 1 , 1)
          call showi ('I','Lagmax', Lagmax ,1 , 1 , 1)
          call showi ('I','Nx' ,    Nx ,    1 , 1 , 1)
          call showi ('I','Mean',   Mean ,  1 , 1 , 1)
          call showr ('O','Hh' ,    Hh ,    Nx , Nfix , Lagmax * Kch )    
          call showi ('O','Nfix',   Nfix ,  1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      memeo no.6178 1994.1.27       
       if( Mfpec .eq. 0) then 
          jen  =  Ndata - Lagmax 
          jshift = 0 
       else 
          jen  =  Ndata + Lagmax 
          jshift  =  - Lagmax 
       end if 
       j = 1 
       do 100 j9 = 1 , jen 
          mfixj  =  Lagmax + j9 + jshift 
          if( Mean .gt. 0) then 
             do 101 i = 1 , Mean 
                Hh ( j , i ) = ( j9 + lagmax ) ** ( i - 1) 
  101        continue 
          end if 
          do 200 m = Lagmax , 1 ,  - 1                  
             mj1  =  m + j9 - 1 + jshift 
             do 300 k = 1 , Kch 
                i  = Mean + ( Lagmax - m ) * Kch + k 
                if( mj1 .ge. 1 .and. mj1 .le. Ndata ) then 
                   if( Rlim .ne. 0.d0 .and. 
     *             Data ( mj1 , k ) .ge. Rlim )
     *             goto 100 
c                  ========
                   Hh ( j , i ) = Data ( mj1 , k )
                else                    
                   Hh ( j , i ) = 0.d0 
                end if 
c            --------- 
  300        continue   
  200     continue 
          do 301 k = 1 , Kch 
             i  = Mean + Lagmax * Kch + k 
             if( mfixj .ge. 1 .and. mfixj .le. Ndata ) then 
                if( Rlim .ne. 0.d0 .and. Data ( mfixj , k ) .ge. Rlim )
     *          goto 100 
c               ------------------------------------------------
                Hh ( j , i ) = Data ( mfixj , k )
             else  
                Hh ( j , i ) = 0.d0 
             end if 
c         --------- 
  301     continue 
          j  =  j + 1 
  100  continue 
       Nfix  =  j - 1 
       goto 9100 
      end  

checkpoint:   lano =    39/129/sp2.@990422.@152623 ........
contents    4.6   indexset            
c reusable
      subroutine indexset (
     i Indextem , Lag , Kch , Lagmax , Kk , Mean , 
     o Longindex , Npar , Id )   
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Longindex ( Mean + Kch * ( Lagmax +1)) ,
     * Indextem ( Kch )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      indexset 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('indexset', io , stio )
          call showm2 ('I',
     i    ' Expands a row  of the index matrix S for the construction',
     i    ' of matrix (4.67) for SAR model fit.')
          call showi ('I','Indextem',  Indextem , 1 , 1 , Kch )
          call showi ('I','Lag' ,      Lag ,    1 , 1 , 1)
          call showi ('I','Kch' ,      Kch ,      1 , 1 , 1)
          call showi ('I','Lagmax' ,   Lagmax ,   1 , 1 , 1)
          call showi ('I','Kk' ,       Kk ,       1 , 1 , 1)
          call showi ('I','Mean' ,     Mean ,     1 , 1 , 1)
          call showi ('O','Indexv',    Longindex ,   1 , 1,
     *    Mean + Lagmax * Kch + Kk )    
          call showi ('O','Npar' ,     Npar ,     1 , 1 , 1)
          call showi ('O','Id' ,       Id ,       1 , 1 , 1)
          call selfend ( myself , io , inisub )     
       end if 
#endif
check CONNECT
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 30 m = 1 , Mean   
   30  Longindex ( m ) = 1 
       Npar = 1 + Mean 
       Id = 1 
       ibb = 1 
       do 2 k = 1 , Kch  
          Id = Id + ibb * Indextem ( k ) 
          ibb = ibb * 2 
          do 1 m = 1 , Lagmax  
             if( m .le. Lag ) then 
                Longindex ( Mean + ( m - 1) * Kch + k ) = 
     *          Indextem ( k ) 
                Npar = Npar + Indextem ( k ) 
             else 
                Longindex ( Mean + ( m - 1) * Kch + k )  =  0   
             end if 
    1     continue 
    2  continue 
       Npar = Npar + Kk - 1  
       do 3 k = 1 , Kk   
          Longindex ( Mean + Lagmax * Kch + k )  =  1 
    3  continue    
       goto 9100 
      end  

checkpoint:  lano =    40/129/sp2.@990422.@152623 ........
contents    4.7   sssolver            
c reusable
      subroutine sssolver (
     i K , Mj , Icnt , Longindex ,
     a Hh ,  
     o A , Sqe )                      
       implicit real  *  8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Hh ( Mj , K + 1) , A ( K ) , Longindex ( K + 1)    
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ..........................................................
c      sssolver 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine produces subset regression coefficients.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0 )
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('sssolver', io , stio )                  
          call showm2 ('I',
     i    ' Composes and solves subset regression equation(4.66)',
     i    ' to get LSE of subset AR model(2.23) parameter.')
          call showm2 ('I',
     i    ' Only columns corresponding $S_{ij} = 1$ of',
     i    ' eq.(4.67)  are produced.')
          call showi ('I','K' ,      K ,      1 , 1 , 1)
          call showi ('I','Mj' ,     Mj ,     1 , 1 , 1)
          call showi ('I','Icnt' ,   Icnt ,   1 , 1 , 1)
          call showi ('I','Indexv' , Longindex , 1 , 1 , K + 1)    
          call showr ('A','Hh',      Hh ,     Mj , K + 1 , K + 1)     
          call showr ('O','A' ,      A ,      1 , 1 , K )
          call showr ('O','Sqe' ,    Sqe ,    1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          k1  =  K + 1 
catch-    call nw
          nw0 = nw ('{' , 0)
          nww = nw ('w' , k1 ** 2)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       ii = 0 
       do  10  i  =  1 , k1 
       if( Longindex ( i ) .eq. 1 ) then 
          ii = ii + 1 
          do  20   j  =  1 , k1 
c         w ( j , ii )  =  Hh ( j , i )   
          wk ( nww +          j 
     *     - 1 +      k1 * (   ii 
     *     - 1))  =  Hh ( j , i )
   20  continue                       
       end if 
   10  continue 
       call hushld (
     i k1 , k1 , ii , 
     A wk ( nww )) 
       call solve (
     i k1 , ii - 1 , ii , Icnt , 
     A wk ( nww ) , 
     o ierr )
c      Sqe  =  w ( ii , ii )
       Sqe  =  wk ( nww +      ii 
     *  - 1 +        k1 * (    ii 
     *  - 1))
       if( Icnt .eq. 0) goto 9100 
c      ------------------------- 
       factor = 1.d0 / dsqrt ( Sqe )
       ii0 = ii 
       ii = 0 
       do  11  i  =  1 , K  
          if( Longindex ( i ) .eq. 1 ) then 
             ii = ii + 1 
c            A ( i ) = w ( ii , ii0)
             A ( i ) = wk ( nww +       ii 
     *        - 1 +        k1 * (   ii0 
     *        - 1))
             do 30 l = 1 , i  
                Hh ( l , k1)  =  
     *          ( Hh ( l , k1 ) - A ( i )* Hh ( l , i ))* factor 
   30        continue     
          else 
             A ( i ) = 0.d0     
          end if 
   11  continue 
       goto 9100 
      end 

#ifdef ARDOCKLINK
checkpoint: lano =    41/129/sp2.@990422.@152623 ........
contents    4.8   click3              
c ardoock-specific
      subroutine click3 (
     i Kch , 
     a Mask ,
     o Action )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Mask ( Kch , Kch ) , iarg (10)
       character*1 Action 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      click3          
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('click3', io , stio )
          call showm ('I',
     i    ' Edits the index matrix.')
          call showi ('I','Kch' ,   Kch ,      1 , 1 , 1)
          call showi ('A','Mask' ,  Mask ,     Kch , Kch , Kch )
          call showc ('O','Action', Action ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
catch- call jfrex 
       j  =  j
       j  =  jfrex ('init' , 1)
       j  =  jfrex ('r', 4)
       j  =  jfrex ('g', 0)
       goto 1500 
c      ========= 
 1008  continue 
       call subwin2 ( Kch , Mask )
 1500  continue 
corrected2000.01.20 1 line correction made by M.I.
c       call keympi ('I','indexm edit: g?r?', Kch , Action , rx , iarg )
       call keympi ('I','indexm edit: g?r?', 4 , Action , rx , iarg )
       if( Action .eq. 'g') goto 9100 
c      --------------------------------------------------- 
       i1 = iarg (1)
       j1 = iarg (2)
       i2 = iarg (3)
       j2 = iarg (4)
       do 2100 ii = i1 , i2 
       do 2101 jj = j1 , j2   
          Mask ( ii , jj ) = 1 - Mask ( ii , jj ) 
 2101  continue 
 2100  continue 
       goto 1008 
      end 
#endif

checkpoint:  lano =    42/129/sp2.@990422.@152623 ........
contents    4.9   subwin2             
c reusable
      subroutine subwin2 (
     i Kch , Mask )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Mask ( Kch , Kch )
       character*12 clab   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      subwin2
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subwin2', io , stio )
          call showm ('I',
     i    ' Shows the index matrix.')
          call showi ('I','Kch' ,   Kch ,   1 , 1 , 1)
          call showi ('I','Mask' ,  Mask ,  Kch , Kch , Kch )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .ne. 0) goto 9100
       do 1005 j = 1 , Kch 
          write(6,1007) clab ( j ),( Mask ( j , i ) , i = 1 , Kch ) 
 1007     format(1x  , a , 15i1)
 1005  continue 
       write(6,*)
       goto 9100 
      end 

checkpoint:   lano =    43/129/sp2.@990422.@152623 ........
contents    4.10  arorder              
c reusable
      subroutine arorder (
     i An , Bn , Hh , Kch , Lagmax , Mean , Nx , Mx ,  
     o Maice , Aicmin ,
     w save , resid , Longindex , str )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension Hh ( Nx , Mx ) ,  
     * save ( Nx ) , resid ( Nx ), Longindex ( Mx ) , str ( Mx , Kch ) 
       dimension indexopt ( MAXCH )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init / 1 /, pi /0.d0/, pi2 /0.d0/
c      ........................................................
c      arorder  
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arorder', io , stio )
          call showm ('I',
     i    ' MAICE of AR order.')
          call showi ('I','Kch' ,   Kch ,       1 , 1 , 1)
          call showi ('I','Lagmax', Lagmax ,    1 , 1 , 1)
          call showi ('I','Mean' ,  Mean ,      1 , 1 , 1)
          call showi ('I','Nx' ,    Nx ,        1 , 1 , 1)
          call showi ('I','Mx' ,    Mx ,        1 , 1 , 1)
          call showr ('I','An',     An ,        1 , 1 , 1)
          call showr ('I','Bn',     Bn ,        1 , 1 , 1)
          call showr ('I','Hh' ,    Hh ,        Nx , Nx , Mx )
          call showi ('O','Maice' , Maice  ,    1 , 1 , 1)    
          call showr ('O','Aicmin', Aicmin ,    1 , 1 , 1)
          call showw ('d' ,     Nx ,        1)
          call showw ('d0',     Nx ,        1)
          call showw ('indexv' ,Mx ,        1)
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          pi  =  atan2 (0.d0 ,  - 1.d0) 
          pi2 = dlog ( pi * 2.d0)
       end if  
c      see. no.6178 1994.1.27 
       mfkf = Mx  
       Aicmin  =  1.d50 
       do 1200 k = 1 , Kch 
          indexopt ( k ) = 1 
 1200  continue 
c       if( Cmd .eq. 'mulmar') goto 9201 
c      -------------------------------- 
       if( myid .eq. 0) then 
          write(6 , '('' order selection '')')
          write(6 , '(''    order    AIC'')')
       end if
       do 1402 lord = 0 , Lagmax  
          aicsum  =  0.d0 
          do 1900 kk = 1 , Kch 
             mmkk = Mean + Lagmax * Kch + kk - 1 
             do 1901 l = 1 , mfkf 
                save ( l ) = Hh ( l , mmkk + 1)
 1901        continue 
             call indexset (
     i       indexopt , lord , Kch , Lagmax , kk , Mean , 
     o       Longindex , npar , id )
             do 1902 l = 1 , mfkf 
                Hh ( l , mmkk + 1) =  save ( l ) 
                resid ( l ) = 0.d0 
 1902        continue 
             resid ( mmkk + 1)  =  Hh ( mmkk + 1 , mmkk + 1) 
             call sssolver (
     i       mmkk , Nx , 0 , Longindex , Hh , 
     o       str , sqez )
             aicx  =  Bn * ( pi2 + dlog ( sqez * An ) + 1) +
     *       2.d0 * npar 
             aicsum  =  aicsum + aicx 
          do 904 l = 1 , mfkf  
             Hh ( l , mmkk + 1)  =  resid ( l )
  904     continue 
 1900     continue 
          do 1203 k = 1 , Kch 
             do 1204 j = 1, Mx 
                Hh ( j , Mean + Lagmax * Kch + k ) = str ( j , k )
 1204        continue 
 1203     continue 
          if( myid .eq. 0) write(6 , '( i7 , f12.2)') lord , aicsum 
          if( aicsum .le. Aicmin ) then 
             Aicmin  =  aicsum 
             Maice =  lord 
          end if  
 1402  continue 
 9201  continue 
       goto 9100 
      end 

checkpoint:    lano =    44/129/sp2.@990422.@152623 ........
contents    4.11  arfile              
c reusable
      subroutine arfile (
     i Cmd , Mt , 
     O Var , Ar , Kch , Lag )  
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       parameter ( ntparam = 23)
       character*60 cLIST ( ntparam )
       character*10 cHLAB ( MAXCH )      
       common  /ctparam/  cLIST , cHLAB 
       character*(*) Cmd 
       dimension Var ( Kch , Kch ) , Ar ( Kch , Kch , MAXLAG )
       character*80 form , formx                    
       character*20 clab 
       character*200 cbuf , cbufx 
       character*1  io 
#ifdef MODIFIER
       character*1 stio , viv  
       data inisub /0/
#endif  
       data  form / '(4d20.10)' / 
c      .........................................................
c      arfile       
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          call areachk (
     i    'arfile' , 'MAXLAG' , MAXLAG , Lag , 1 ,
     o    ierr )
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arfile', io , stio )
          call showm ('I',
     i    ' Calls arfilw.')
          call showc ('I','Cmd' ,  Cmd ,     1 , 1 , 1)
          if( Cmd .eq. '-->') then
             viv = 'O'
          else
             viv = 'I'
          end if
          call showi ('I','Mt'  ,  Mt ,      1 , 1 , 1)
          call showr (viv,'Var' ,  Var ,     Kch , Kch , Kch )    
          call showr (viv,'Ar' ,   Ar ,      Kch , Kch , Kch )
          call showi (viv,'Kch' ,  Kch  ,    1 , 1 , 1)
          call showi (viv,'Lag' ,  Lag ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( mYID .ne. 0) goto 9100 
       icnt  =  0 
       if( Cmd .eq. '<--') icnt  =  1 
       mx  = Kch 
       lagx = Lag 
       if( icnt .gt. 0) then 
           write( Mt , '(''DATASTARTINGLINE'')')
           call iset ('arorder' , Lag )
           call iset ('archannel' , Kch )
           call cset ('arlabel' , 'yes')
           call rparam (
     i     Mt , 'write' , 
     o     ipos , ierr ) 
           ln = 0 
           do 6199 j = 1 , Kch 
               if( j .eq. 1) then 
catch-            call clab 
                  cbuf = '''' // clab ( j )
               else 
                  cbufx = cbuf (1:ln ) // ' ''' // clab ( j )
                  cbuf = cbufx 
               end if 
               lnx = ln 
               do 6198 l = lnx + 20 , lnx ,  - 1 
                  ln  =  ln 
                  if( cbuf ( l:l ) .ne. ' ') then 
                      cbufx  =  cbuf (1:l ) // ''''
                      cbuf = cbufx 
                      ln  =  l + 1 
                      goto 6199 
                  end if 
 6198         continue 
 6199     continue 
          write( Mt , '( a )') cbuf 
          write( Mt , '( a )') form 
       else 
          call ready (
     i    Mt )
          call rparam (
     i    Mt , 'init' , ipos , ierr )
          call rparam (
     i    Mt , 'read' , ipos , ierr )
          call rparam (
     i    Mt , 'show' , ipos , ierr )
catch-    call ipar 
          lagx = ipar ('arorder')
          mx = ipar ('archannel')
          if( ipar ('arlabel') .eq. 1) then 
             read ( Mt ,  * ) ( cHLAB ( j ) , j = 1 , mx )
             write(6,*) 'channels:' , ( cHLAB ( j ) , j = 1 , mx )
          end if 
          read ( Mt , '( a )') formx 
       end if 
       call arfilw (
     i form , formx , Mt , mx , lagx , icnt , 
     I Var , Ar )
       if( icnt .eq. 0) then 
          Kch = mx 
          Lag = lagx 
       end if 
       goto 9100 
      end 

checkpoint:     lano =    45/129/sp2.@990422.@152623 ........
contents    4.12  arfilw             
c reusable
      subroutine arfilw (
     i Form , Formx , Mt , Kch , Lag , Icnt , 
     I Var , Ar )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*(*) Form , Formx 
       dimension Var ( Kch , Kch ) , Ar ( Kch , Kch , Lag )
       character*1  io 
#ifdef MODIFIER
       character*1 stio , viv 
       data inisub /0/
#endif  
c      ........................................................
c      arfilw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arfilw', io , stio )
          call showm2 ('I',
     i    ' Read/writes AR model parameter file.',
     i    ' See Section 5.4.2 of CSM.')
          call showc ('I','Form' ,  Form ,    1 , 1 , 1)
          call showc ('I','Formx' , Formx ,   1 , 1 , 1)
          call showi ('I','Mt' ,    Mt ,      1 , 1 , 1)
          call showi ('I','Kch' ,   Kch ,     1 , 1 , 1)
          call showi ('I','Lag' ,   Lag ,     1 , 1 , 1)
          call showi ('I','Icnt' ,  Icnt ,    1 , 1 , 1)
          if( Icnt .gt. 0) then
             viv = 'I'
          else
             viv = 'O'
          end if
          call showr (viv,'Var' ,   Var ,     Kch , Kch , Kch )    
          call showr (viv,'Ar' ,    Ar ,      Kch , Kch , Kch )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 300 ii = 1 , Kch 
          if( Icnt .gt. 0) then 
              write( Mt , Form ) ( Var ( ii , jj ) , jj = 1 , Kch )
          else 
              read ( Mt , Formx ) ( Var ( ii , jj ) , jj = 1 , Kch )
          end if 
  300  continue 
       if( Lag .le. 0) goto 9100 
c      ------------------------- 
       do 400 i = 1 , Lag 
          do 450 ii = 1 , Kch 
              if( Icnt .gt. 0) then 
                 write( Mt , Form )( Ar ( ii , jj , i ), jj = 1 , Kch )
              else 
                 read( Mt , Formx )( Ar ( ii , jj , i ), jj = 1 , Kch )
              end if 
  450     continue 
  400  continue 
       goto 9100 
      end 

#ifdef ARDOCKLINK
checkpoint:      lano =    46/129/sp2.@990422.@152623 ........
contents  5. marts                subpackage
contents    5.1   marts               
c ardock-specific
      subroutine marts (
     i Par , Npar , 
     o El , Lel ) 
       implicit real*8 ( a-h , o-z )     
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX  
       common  /cmarts/  mEAN , nSYS , lAGOPT, 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       dimension Par ( Npar ) , El (1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      marts 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          iw0 = iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('marts', io , stio )
          call showm2 ('I',
     i    ' Computes the log likelihood of E-MARTS model(2.30).',
     i    ' Reserves work area and calls martsw.')
          call showr ('I','Par' ,    Par ,      1 , 1 , Npar + 1)
          call showi ('I','Npar' ,   Npar ,     1 , 1 , 1)
          call showm ('I','information supplied through common')
          call showi ('I','kCH' ,    kCH ,      1 , 1 , 1)
          call showi ('I','lISTPE' , lISTPE ,   1 , 1 , kCH )
          call showi ('I','lAGMAX' , lAGMAX ,   1 , 1 , 1)
          call showi ('I','nDATA' ,  nDATA ,    1 , 1 , 1)
          call showr ('O','El' ,     El ,       1 , 1 , Lel + 1)
          call showi ('A','Lel' ,    Lel ,      1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          iw0 = iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       my = kCH 
       mv = 3 * kCH 
       lp = 0 
       do 1 j = 1 , kCH 
          lp  =  lp + lISTPE ( j ) - 1 
    1  continue     
       mz = lp + kCH * ( lAGMAX + mEAN +3)
       mn = nDATA 
       maxl  =  kCH ** 2 * lAGMAX + ( lAGMAX - 1) * kCH + 
     * lp * 2 + kCH * ( 3 + mEAN * 2 )
       call martsw (
     i Par , Npar , my , mv , mz , mn , maxl , 
     o El , Lel , 
     w wk ( nw ('var' , my * my )) , 
     w wk ( nw ('ar' , my * my * lAGMAX )) , 
     w wk ( nw ('z' , mz * ( mn + 1))) , 
     w wk ( nw ('v' , mz * mz * ( mn + 1))) , 
     w wk ( nw ('g' , mz * mv )) , 
     w wk ( nw ('sigv' , mv * mv )) , wk ( nw ('sigr' , my * my )) , 
     w wk ( nw ('vf' , maxl )) , iwk ( iw ('irf' , maxl )) ,
     w iwk ( iw ('icf' , maxl )) , 
     w wk ( nw ('vh' , maxl )) , iwk ( iw ('irh' , maxl )) , 
     w iwk ( iw ('ich' , maxl )), wk ( nw ('dop' , mEAN + 3)))
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:       lano =    47/129/sp2.@990422.@152623 ........
contents    5.2   martsw              
c ardock-specific
      subroutine martsw (
     i Par , Npar , My , Mv , Mz , Mn , Maxl ,  
     o El , Lel , 
     w var , ar , z , v , g , sigv , sigr , vf , irf , icf , vh ,
     w irh , ich , dop )
       implicit real*8 ( a-h , o-z )     
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( Npar ) , El (1)
       dimension z ( Mz , 0: Mn ) ,  v ( Mz , Mz , 0: Mn ) , 
     * g ( Mz , Mv ) 
       dimension sigv ( Mv , Mv ) ,  sigr ( My , My ) 
       dimension icf ( Maxl ) , irf ( Maxl ) , vf ( Maxl )     
       dimension ich ( Maxl ) , irh ( Maxl ) , vh ( Maxl ) 
       dimension var ( My , My ) ,  ar ( My , My , 10), part (100)
       dimension dop ( mEAN + 3) 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
       data mdiff /0/, ionce /0/
c      ........................................................
c      martsw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed. 
       call areachk (
     i 'martsw','{',0,0,0,
     o ierr )
       if( ierr .eq. 1) then
          Lel = 0
          return
       end if
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          iNITMART  =  0     
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('martsw', io , stio )
          call showm3 ('I',
     i    ' Computes the log likelihood of E-MARTS model(2.30),',
     i    ' using state space representation (2.21).', 
     i    ' see p.30 and Section 2.6 of CSM.')
          call showm ('I',
     i    ' Calls subroutines  martspar and kalman.')
          call showr ('I','Par' ,     Par ,     1 , 1 , Npar )
          call showi ('I','Npar' ,    Npar ,    1 , 1 , 1)    
          call showi ('I','My' ,      My ,      1 , 1 , 1)    
          call showi ('I','Mv' ,      Mv ,      1 , 1 , 1)
          call showi ('I','Mz' ,      Mz ,      1 , 1 , 1)
          call showi ('I','Mn' ,      Mn ,      1 , 1 , 1)    
          call showi ('I','Maxl' ,    Maxl ,    1 , 1 , 1)     
          call showm ('I','information supplied through common')
          call showr ('I','dATA' ,    dATA ,    nDATA , nDATA , kCH )
          call showr ('I','rLIM' ,    rLIM ,    1 , 1 , 1)
          call showi ('I','kCH' ,     kCH ,     1 , 1 , 1)
          call showi ('I','nDATA' ,   nDATA ,   1 , 1 , 1)
          call showi ('I','lISTPE',   lISTPE ,  1 , 1 , kCH )
          call showi ('I','mEAN' ,    mEAN ,    1 , 1 , 1)
          call showi ('I','lAGOPT',   lAGOPT ,  1 , 1 , 1)
          call showi ('I','iNITMART', iNITMART ,1 , 1 , 1)
          call showr ('O','El' ,      El ,      1 , 1 , Lel + 1)
          call showi ('O','Lel',      Lel ,     1 , 1 , 1)
          call showw ('var' ,  My , My )    
          call showw ('ar' ,   My , My )
          call showw ('z' ,    Mz , Mn + 1)    
          call showw ('v' ,    Mz , Mz )
          call showw ('g' ,    Mz , Mv )
          call showw ('sigv' , Mv , Mv )    
          call showw ('sigr' , My , My )
          call showw ('vf' ,   1 , Maxl )
          call showw ('icf' ,  1 , Maxl )
          call showw ('irf' ,  1 , Maxl )    
          call showw ('vh' ,   1 , Maxl )
          call showw ('ich' ,  1 , Maxl )    
          call showw ('irh' ,  1 , Maxl )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Lel  =  0 
#ifdef AUTHOR 
       call snum ('nparm' ,  - 1 , Npar * 1.d0 , '( f5.0)') 
#endif 
       if( iNITMART .eq. 1) then
          do 5000 i = 1 , Mv 
          do 1000 j = 1 , Mv 
             sigv ( i , j )  =  0.d0 
 1000     continue 
 5000     continue 
          do 5001 i = 1 , Mz 
          do 1001 j = 1 , Mv 
             g ( i , j )  =  0.d0 
 1001     continue   
 5001     continue
          do 1011 i = 1 , Mz 
             do 1012 j = 1 , Mz     
                v ( i , j , 0)  =  0.d0  
 1012        continue 
             if( mEAN .eq. 0) v ( i , i , 0)  =  1.d5 
             z ( i , 0) = 0.d0     
 1011     continue 
c         sigr construction
          do 901 ii = 1 , kCH  
          do 902 jj = 1 , kCH  
             sigr ( ii, jj )  =  0.d0 
  902     continue 
  901     continue 
          dop (1) = 1.d0
          dop (2) = -1.d0
          mdiff = mEAN
          if( mEAN .eq. 0) mdiff = 2
          do 903 ii = 2 , mdiff 
             dop ( ii + 1) = 0.d0
             do 904 jj = ii , 1 , -1
  904        dop ( jj + 1) = dop ( jj + 1) - dop ( jj ) 
  903     continue
       end if   
       nf  =  0 
       nh  =  0 
       iz  =  0   
       iv  =  0   
c      F_X , G_X and H_X construction
       call martspar (
     i '-->' , 'var' , 0 ,
     i Par , Npar , Kch , Kch ,  
     o var , Ival )  
       call martspar (
     i '-->' , 'ar' , 0 , 
     i Par , Npar , Kch , Kch ,  
     o ar , lAGOPT )  
       do 1500 k = 1 , lAGOPT 
       do 1401 nch = 1 , kCH 
          iz  =  iz + 1 
          do 401 mch = 1 , kCH 
             nf  =  nf + 1 
             vf ( nf )  =  ar ( mch , nch , k ) 
             if( iNITMART .eq. 1) then
                irf ( nf )  =  mch 
                icf ( nf )  =  iz  
             end if 
  401     continue 
          if( k .eq. 1) then 
             iv  =  iv + 1   
             nh  =  nh + 1   
             if( iNITMART .eq. 1) then
                irh ( nh )  =  iz 
                ich ( nh )  =  iz 
                vh ( nh )  =  1.d0 
                g ( iz , iv )  =  1.d0
             end if 
             do 309 mch = 1 , kCH  
             sigv ( iv , mch )  =  var ( iv , mch )
  309        continue 
          else 
             nf  =  nf + 1 
             if( iNITMART .eq. 1) then  
                irf ( nf )  =  iz 
                icf ( nf )  =  iz - kCH 
                vf ( nf )  =  1.d0 
             end if
          end if   
 1401  continue     
 1500  continue     
c      F_T , G_T and H_T construction
       do 1600 nch = 1 , kCH 
          iz  =  iz + 1 
          if( mEAN .eq. 0) then
             nh  =  nh + 1 
             iv  =  iv + 1 
             if( iNITMART .eq. 1) then
                irh ( nh )  =  nch 
                ich ( nh )  =  iz  
                vh ( nh )  =  1.d0     
                g ( iz , iv )  =  1.d0  
                call martspar (
     i          '-->' , 'tvar' , nch ,
     i          Par , Npar , 1 , 1 ,  
     o          sigv ( iv , iv ) , Ival )
                if( sigv ( iv , iv ) .lt. 0.d0) goto 9100
c               -----------------------------------------------
             end if
          else
             nf  =  nf + 1 
             if( iNITMART .eq. 1) then
                irf ( nf )  =  nch 
                icf ( nf )  =  iz  
                vf ( nf )  =  1.d0     
             end if
          end if
          call martspar (
     i    '-->' , 'trinit' , nch ,
     i    Par , Npar , mdiff , 1 ,  
     o    part , Ival )
          do 1603 ii = 1, mdiff 
             if( ii .eq. 1) then
                do 1604 jj = 1, mdiff 
                   nf  =  nf + 1 
                   if( iNITMART .eq. 1) then
                      irf ( nf )  =  iz  
                      icf ( nf )  =  iz + jj - 1  
                      vf ( nf )  =  - dop ( jj + 1) 
                   end if 
                   z ( iz + jj - 1, 0)  =  part ( jj )
                   v ( iz + jj - 1, iz + jj - 1, 0)  =  0.d0 
 1604           continue  
             else  
                nf  =  nf + 1 
                iz  =  iz + 1 
                if( iNITMART .eq. 1) then
                   irf ( nf )  =  iz 
                   icf ( nf )  =  iz -1
                   vf ( nf )  =  1.d0
                end if 
             end if
 1603     continue     
 1600  continue
       if( mEAN .eq. 0) then     
c         F_S, G_S and H_S construction
          do 1602 nch = 1 , kCH 
             if( lISTPE ( nch ) .ne. 1) then 
                iz  =  iz + 1   
                iv  =  iv + 1   
                nh  =  nh + 1   
                if( iNITMART .eq. 1) then
                   g ( iz , iv )  =  1.d0 
                   irh ( nh )  =  nch   
                   ich ( nh )  =  iz 
                   vh ( nh )  =  1.d0 
                end if
                call martspar (
     i          '-->' , 'svar' , nch ,
     i          Par , Npar , 1 , 1 ,  
     o          sigv ( iv , iv ) , Ival )  
                if( sigv ( iv , iv ) .lt. 0.d0) goto 9100
c               -----------------------------------------------
                do 1601 i = 1 , lISTPE ( nch ) - 1                           
                   nf  =  nf + 1 
                   if( iNITMART .eq. 1) then
                      irf ( nf )  =  iz  
                      icf ( nf )  =  iz + i - 1                       
                      vf ( nf )  =   - 1.d0 
                   end if  
                   if( i .gt. 1) then 
                      nf  =  nf + 1 
                      if( iNITMART .eq. 1) then  
                         irf ( nf )  =  iz + i - 1                    
                         icf ( nf )  =  iz + i - 2                    
                         vf ( nf )  =  1.d0 
                      end if
                   end if 
 1601           continue 
                iz  =  iz + lISTPE ( nch )  - 2                     
             end if   
 1602     continue
       end if
#ifdef MODIFIER
c       ionce = 1
       if( ionce .eq. 0) then
          ionce = 1
          call fmatrix( 'F', vf , irf , icf , nf , iz )
       end if    
#endif
       call areachk (
     i 'martsw' , 'maxl' , Maxl , nf , 1 ,
     o ierr )
       call areachk (
     i 'martsw' , 'maxl' , Maxl , nh , 1 ,
     o ierr ) 
       n0 = lAGMAX 
catch- call rpar 
       rLIM  =  rpar ('missing')
c      Kalman filter 
       call kalman (
     i dATA , rLIM , g , sigv , sigr , vf , irf , icf , nf ,  
     i vh , irh , ich , nh , n0 , 
     i kCH , iv , iz , nDATA , My , Mv , Mz , Mn , 
     a z , v , 
     o El , Lel )
       goto 9100 
      end   
#endif

#ifdef ARDOCKLINK
checkpoint:        lano =    48/129/sp2.@990422.@152623 ........
contents    5.3   martspar            
c ardock-specific
      subroutine martspar (
     i Cmd , Key , Nch ,
     I Par , Npar , Ir , Ic ,  
     O Val , Ival )  
       implicit real*8 ( a-h , o-z )    
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       character*(*) Cmd , Key            
       dimension Ival ( Ir , Ic , MAXLAG ) , Val ( Ir , Ic , MAXLAG )
       dimension Par ( MAXPAR )
       character*12 clab    
       character*1  io 
#ifdef MODIFIER
       character*1 stio , viv , vov  
       data inisub /0/
#endif 
c      .........................................................
c      martspar 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          if( Icnt .eq. 1 .and. Key .eq. 'ar') Npar = lpos  
          call areachk (
     i    'martspar','maxspar', MAXPAR , Npar ,1,
     o    ierr )
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('martspar', io , stio )                  
          call showm2 ('I',
     i    ' Code/decode E-MARTS model parameter vector.',
     i    ' See p.30 and Section 2.6 of CSM.')
          call showc ('I','Cmd' ,   Cmd ,      1 , 1 , 1)
          if( Cmd .eq. '-->') then
             viv = 'I'
             vov = 'O'
          else
             viv = 'O'
             vov = 'I'
          end if
          call showc ('I','Key' ,   Key ,      1 , 1 , 1)
          call showi ('I','Nch' ,   Nch ,      1 , 1 , 1)
          call showr (viv,'Par' ,   Par ,      1 , 1 , Npar )    
          call showi (viv,'Npar' ,  Npar ,     1 , 1 , 1)
          call showi (vov,'Ir' ,    Ir   ,     1 , 1 , 1)
          call showi (vov,'Ic' ,    Ic   ,     1 , 1 , 1)
          call showr (vov,'Val' ,   Val ,      Ir , Ir , Ic )     
          call showi (vov,'Ival' ,  Ival ,     Ir , Ir , Ic )     
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Key .eq. 'channel') then
          Ival (1,1,1) = kCH 
          go to 9100
       end if 
       if( Key .eq. 'model' .and. mYID .eq. 0) then
          write(6,*)  
          write(6,*) 'E-MARTS model' 
       end if 
       Icnt  =   - 1 
       if( Cmd .eq. '<--') Icnt  =  1 
       lpos = 0 
       meanx = mEAN 
       if( mEAN .eq. 0) then 
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,*) '   mean component: trend+seasonal' 
          end if 
          do 8787 k = 1 , kCH     
             if( Key .eq. 'tvar' .and. Nch .eq. k ) then
                if( icnt .eq. -1 ) then 
                   Val (1,1,1) = par ( lpos + 1)  
                else 
                   par ( lpos + 1) = Val (1,1,1)   
                end if 
             end if 
             lpos = lpos + 1   
 8787     continue 
          if( Key .eq. 'tvar') then
             goto 9100
          end if 
          do 8788 k = 1 , kCH     
             if( lISTPE ( k ) .ne. 1) then 
                if( Key .eq. 'svar' .and. Nch .eq. k ) then
                   if( icnt .eq. -1 ) then 
                      Val (1,1,1) = par ( lpos + 1) 
                   else 
                      par ( lpos + 1) = Val (1,1,1)  
                   end if 
                end if 
                lpos = lpos + 1
             end if 
 8788     continue 
          if( Key .eq. 'svar') then
             goto 9100
          end if 
          meanx = 2  
       else
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,*) '   mean component: polynomial of order',
     *       mEAN - 1
          end if 
       end if
       do 881 ii = 1, Kch
          if( Key .eq. 'trinit' .and. Nch .eq. ii ) then
             do 882 jj =1, meanx  
                if( icnt .eq. -1 ) then 
                   Val ( jj ,1,1) = par ( lpos + jj )
                else  
                   par ( lpos + jj ) = Val ( jj ,1,1)   
                end if 
  882        continue 
          end if
          lpos = lpos + meanx   
  881  continue   
       if( Key .eq. 'trinit') then
          goto 9100
       end if 
       if( Key .eq. 'model' .and. mYID .eq. 0 ) then 
          write(6,*) '   SAR index matrix'
          do 600 ii = 1 , kCH 
             write(6,'(''  '', a ,10i2)') clab ( ii ), 
     *       ( iNDEXM ( ii + ( jj -1)* kCH ) , jj =1, kCH )                
  600     continue       
       end if
       if( nSYS .lt. kCH ) then 
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,*) '   TAR with controller dim.', kCH - nSYS  
          end if 
          nukp = lpos  + 1 
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,'(''        sight:'',f10.3)') 
     *       dexp ( par ( lpos + 1))     
          end if 
          if( Key .eq. 'sight') then
             if( icnt .eq. -1 ) then 
                Val ( 1,1,1) = par ( lpos + 1)
             else
                par ( lpos + 1) = Val ( 1,1,1) 
             end if 
             lpos = lpos + 1 
             goto 9100
          end if 
          lpos = lpos + 1 
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,'(''    v-weights:'',5f10.3)') 
     *       ( dexp ( par ( lpos + jj )) , jj = 1, kCH - 1)     
          end if 
          if( Key .eq. 'v-weights') then
             do 883 jj =1, kCH - 1 
                if( icnt .eq. -1 ) then 
                   Val ( jj ,1,1) = par ( lpos + jj ) 
                else 
                   par ( lpos + jj ) = Val ( jj ,1,1)  
                end if 
  883        continue 
             lpos = lpos + kCH - 1 
             goto 9100
          end if 
          lpos = lpos + kCH - 1 
          if( Key .eq. 'model' .and. mYID .eq. 0) then
             write(6,'(''    d-weights:'',5f10.3)') 
     *       ( dexp ( par ( lpos + jj )) , jj = 1, kCH )     
          end if 
          if( Key .eq. 'd-weights') then
             do 884 jj =1, kCH  
                if( icnt .eq. -1 ) then 
                   Val ( jj ,1,1) = par ( lpos + jj ) 
                else 
                   par ( lpos + jj ) = Val ( jj ,1,1)  
                end if 
  884        continue 
             lpos  =  lpos + kCH  
             goto 9100
          end if 
          lpos  =  lpos + kCH  
       end if 
       if( Key .eq. 'var') then 
          if( Icnt .eq. 1 ) then 
             call posmat (
     i       'root' , kCH , kCH , 
     a       Val , 
     o       det , ierr )      
          end if 
          do 309 ii = 1 , kCH 
          do 308 jj = 1 , ii     
             lpos  =  lpos + 1   
             if( Icnt .eq.  - 1) then 
                Val ( ii , jj , 1 )  =  Par ( lpos )
             else 
                Par ( lpos )  =  Val ( ii , jj , 1 )
             end if 
  308     continue     
  309     continue  
          if( Icnt .eq.  - 1) then 
             call posmat (
     i       'make' , kCH , kCH , 
     a       Val , 
     o       det , ierr )      
          end if 
          goto 9100 
       end if
       if( Key .eq. 'ar') then
          lpos = lpos + ( kCH * ( kCH + 1))/2
          if( Icnt .eq.  - 1) then 
             lagtem  =  100 
          else 
             lagtem  =  Ival (1,1,1)
          end if 
          do 500 k = 1 , lagtem     
          do 400 ii = 1 , nSYS 
          do 401 jj = 1 , Kch
             if( iNDEXM ( ii + ( jj -1)* kCH ) .eq. 1 ) then   
                lpos  =  lpos + 1 
                if( Icnt .eq.  - 1) then 
                   if( lpos .gt. Npar ) then 
                      Ival (1,1,1) =  k - 1 
                      goto 501 
                   end if 
                   Val ( ii , jj , k ) = Par ( lpos )
                else 
                   Par ( lpos ) = Val ( ii , jj , k )
                end if 
             else 
                if( Icnt .eq. -1) Val ( ii , jj , k ) = 0.d0 
             end if  
  401     continue   
  400     continue 
  500     continue   
  501     continue 
          lag = Ival (1,1,1) 
          if( Icnt .eq.  - 1 .and. nSYS .lt. kCH ) then
             call tarmodel (
     i       Par ( nukp ) , kCH , Lag , nSYS , 
     a       Val )
          end if
       end if 
       goto 9100 
      end     
#endif

#ifdef ARDOCKLINK
checkpoint:         lano =    49/129/sp2.@990422.@152623 ........
contents    5.4   gmarts              
c ardock-specific
      subroutine gmarts (
     o Par , Npar )
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( MAXPAR ) 
       character*1 ckey 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      gmarts 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0  =  nw ('}' , nw0)
          iw0  =  iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gmarts', io , stio )                  
          call showm3 ('I',
     i    ' Produces an initial guess of the parameter of the E-MARTS ',
     i    ' model(2.30).',
     i    ' Calls gmartw. ')
          call showr ('O','Par' ,    Par ,    1 , 1 , Npar )     
          call showi ('O','Npar' ,   Npar ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0  =  nw ('{' , 0)
          iw0  =  iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .eq. 0) then 
          call keysave ('i','max AR order:' , 1 , ckey , rx , lAGLIM )
          if( lAGLIM .gt. lAGMAX ) lAGLIM = lAGMAX 
catch-    call jfrex 
          j = j 
          j = jfrex ('init' , 1)
          j = jfrex ('p' , 1)
          j = jfrex ('s' , 0)
          j = jfrex ('c' , 0)
          j = jfrex ('l' , 0)
          j = jfrex ('1' , 0)
          j = jfrex ('2' , 0)
          j = jfrex ('3' , 0)
          j = jfrex ('4' , 0)
          j = jfrex ('5' , 0)
          j = jfrex ('6' , 0)
          j = jfrex ('7' , 0)
          j = jfrex ('8' , 0)
          j = jfrex ('9' , 0)
          call keysave ('I','mean component: c?l?s?' , 0 , ckey ,
     *    rx , iarg1 )
          mEAN  =  1
          if( ckey .eq. 'p') mEAN = iarg1 + 1 
          if( ckey .eq. '9') mEAN  =  10 
          if( ckey .eq. '8') mEAN  =  9 
          if( ckey .eq. '7') mEAN  =  8 
          if( ckey .eq. '6') mEAN  =  7 
          if( ckey .eq. '5') mEAN  =  6 
          if( ckey .eq. '4') mEAN  =  5 
          if( ckey .eq. '3') mEAN  =  4 
          if( ckey .eq. '2') mEAN  =  3
          if( ckey .eq. 'l') mEAN  =  2 
          if( ckey .eq. 's') mEAN  =  0 
       end if 
#ifdef MPI 
       call mpi_bcast ( lAGLIM , 1 , MPI_INTEGER , 0 , 
     * MPI_COMM_WORLD , ierr )
       call mpi_bcast ( mEAN , 1 , MPI_INTEGER , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
       mdiff = mEAN 
       if( mdiff .eq. 0 ) mdiff = 2
       call gmartw (
     i dATA , nDATA , mdiff ,
     o Par , Npar , 
     w wk ( nw ('resid' , nDATA * kCH )), 
     w wk ( nw ('trend' , nDATA * kCH )),
     w wk ( nw ('seas' ,  nDATA * kCH )),
     w wk ( nw ('poly' ,  kCH * mdiff )), 
     w wk ( nw ('trinit', kCH * mdiff )))
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:          lano =    50/129/sp2.@990422.@152623 ........
contents    5.5   gmartw             
      subroutine gmartw (
     i Datax , Ia , mdiff ,
     o Par , Npar , 
     w resid , trend , seas , poly , trinit )
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( MAXPAR ) , part ( 100 )
       dimension ar ( MAXCH , MAXCH , MAXLAG) , var ( MAXCH , MAXCH )
       dimension vtrend ( MAXCH ) , vseas ( MAXCH ) ,
     * trinit ( mdiff , MAXCH ) , poly ( kCH , mdiff )
       dimension Datax ( Ia ,10), resid ( Ia * kch ), trend ( Ia , 10),
     * seas ( Ia , 10 )
       character*12 clab 
       character*1 ckey           
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
       data iguess  / 0 / 
#endif 
c      ........................................................
c      gmartw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed. 
       call areachk (
     i 'gmartw','{',0,0,0,
     o ierr )
       call mpistop ( ierr )
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gmartw', io , stio )                  
corrected2000.10.20  1 line correction made by M.I.
c          call showm ('I',
          call showm2 ('I',
     i    ' Produces an initial guess of the parameter of the E-MARTS ',
     i    ' model(2.30).')
          call showm3 ('I',
     i    ' 1. Apply BAYSEA procedure to each channel data, to obtain',
     i    '   residual series, initial value of trend and estimates',
     i    '   of $ \Sigma_T$ and $ \Sigma_S$.')
          call showm3 ('I',
     i    ' 2. Fit MAR/SAR model to the multivariate residual series',
     i    '   to obtain initial guess of \{$A_m$\} and $ \Sigma$.',
     i    ' 3. User can force the TAR structure for the AR component.')
          call showr ('I','Datax', Datax ,    Ia , Ia , 10)    
          call showi ('I','Ia' ,   Ia ,       1 , 1 , 1)
          call showr ('O','Par' ,  Par ,      1 , 1 , Npar )     
          call showi ('O','Npar',  Npar ,     1 , 1 , 1)
          call showw ('resid' ,    Ia ,       kCH )     
          call showw ('poly' ,     kCH,       mEAN )     
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Npar = 0 
       ifull = 0
       ista = 1 
       iend  =  kCH 
       if( mEAN .eq. 0) then 
          if( mYID .eq. 0) then
             write(6,'(2x,''channels are:'',5A)') 
     *       ( clab ( j ), j = 1, kCH )
          end if
          call keympi ('i','give periods:' , kCH , ckey , abuse , 
     *    lISTPE )
          call keympi ('c','search mode: f?a?m?' , 0 , ckey , abuse , 
     *    ix ) 
          iauto  =  1 
          if( ckey .eq. 'f' .or. ckey .eq. 'F') ifull  =  1 
          if( ifull .eq. 1) then 
             call mpion (
     o       mpiflag )
             if( mpiflag .eq. 1) then 
                call mpison (
     i          1 , kCH , 
     o          ista , iend )
             end if 
          end if 
       end if
       do 6941 nch  =  ista , iend 
          do 1564 i = 1 , nDATA 
             resid ( i + ( nch -1 )* nDATA ) = Datax ( i , nch )
 1564     continue
          if( mEAN .ne. 0) goto 6941
c         --------------------------
          if( ifull .eq. 0) then 
             if( nch .gt. 1) then 
                call keympi ('c','search mode: a?m?' ,
     *          0 , ckey , abuse , ix )
                iauto  =  1 
             end if 
             if( ckey .eq. 'm') iauto  =  0 
          end if 
          if( iauto .eq. 0) then 
             call keympi ('r','abuse-factor:' , 1 , ckey , abuse , ix )
          else 
             abuse  =  30.d0 
          end if 
#ifdef    AUTHOR 
          call snum ('abuse - factor' , iguess , abuse , '( f8.3)')
#endif 
          call sadjust (
     i    abuse , nch , iauto , lISTPE ( nch ) , nDATA , lAGMAX , 
     a    resid (1+ ( nch -1)* nDATA ) , trend (1, nch ), 
     a    seas (1, nch ),
     o    trinit (1 , nch ) , vtrend ( nch ) , vseas ( nch ))
 6941  continue   
#ifdef MPI 
       if( ifull .eq. 1) then 
          call mpioff (
     i    mpiflag )
          if( mpiflag .eq. 1) then 
             call mpisoff (
     i       vtrend ( ista ) , iend - ista + 1 , MPI_DOUBLE_PRECISION , 
     o       vtrend )
             call mpisoff (
     i       vseas ( ista ) , iend - ista + 1 , MPI_DOUBLE_PRECISION , 
     i       vseas )
             ircntr = ( iend - ista + 1) * nDATA 
             idispr = ( ista - 1) * nDATA 
             call mpisres (
     i       idispr + 1 , ircntr )
             call mpisoff (
     i       resid ( idispr + 1 ) , ircntr , MPI_DOUBLE_PRECISION , 
     o       resid )
             ircntr = ( iend - ista + 1) * 2 
             idispr = ( ista - 1) * 2 
             call mpisres (
     i       idispr + 1 , ircntr )
             call mpisoff (
     i       trinit ( idispr + 1 , 1) , ircntr , MPI_DOUBLE_PRECISION , 
     o       trinit )
          end if 
       end if 
#endif 
       call bug (1,0,0,0,'arfit', nDATA , 
     * resid ( nDATA * kCH ), message )
       call arfit (
     i resid , nDATA , kCH , lAGLIM , mEAN , 
     o aic , var , ar , poly , lAGOPT , iNDEXM ) 
       if( mEAN .gt. 0) then
          do 1124 nch = 1, kCH
             t = 2
             do 1125 ii = 1, mEAN
                t = t - 1.d0
                sum = 0.d0
                do 1122 jj = 1, mEAN
                   sum = sum + poly ( nch , jj ) * t ** (jj - 1)
 1122           continue
                trinit ( ii , nch ) = sum
 1125        continue 
 1124     continue
          do 1123 nch = 1, kCH
             vtrend ( nch ) = 0.d0
             vseas ( nch ) = 0.d0 
 1123     continue 
       end if
       do 8787 nch = 1 , kCH 
          call martspar (
     i    '<--' , 'tvar' , nch ,
     o    Par , Npar , 
     i    1 , 1 , vtrend ( nch ) , Ival )  
          if( lISTPE ( nch ) .ne. 1) then  
             call martspar (
     i       '<--' , 'svar' , nch ,
     o       Par , Npar , 
     i       1 , 1 , vseas ( nch ) , Ival )
          end if  
 8787  continue 
 8942  continue 
       do 9787 nch = 1 , kCH 
          nq2 = mEAN 
          if( mEAN .eq. 0) nq2 = 2   
          call martspar (
     i    '<--' , 'trinit' , nch ,
     o    Par , Npar , 
     i    nq2 , 1 , trinit(1, nch ) , Ival )
 9787  continue 
       call bug (1,0,0,0,'tarmodel', lAGOPT , aic , message )
       call keympi 
     * ('i','TAR controller dim.:',1, ckey , rkey , nSYS )
       nSYS = kCH - nSYS 
       if( nSYS .lt. kCH ) then 
          np  =  Npar + 1 
          if( myid .eq. 0) then 
             call keysave ('r','sight:' , 1 , ckey , part , ix )
             part (1) = dlog ( part (1))
             call martspar (
     i       '<--' , 'sight' , 0 ,
     o       Par , Npar , 
     i       1 , 1 , part , Ival )  
             write(6,*) 'input' , kCH - 1 , 'weights'     
             if( kCH .gt. 1) then 
                np = np + kCH - 1 
                call keysave ('r','v-weights:' , kCH - 1 , ckey , 
     *          part , ix )
                do 100 i = 1, kCH - 1
  100           part ( i ) = dlog ( part ( i ))
                call martspar (
     i          '<--' , 'v-weights' , 0 ,
     o          Par , Npar , 
     i          kCH -1 , 1 , part , Ival )  
             end if       
             np = np + kCH  
             write(6,*) 'input' , kCH , 'diff weights' 
             call keysave ('r','d-weights:' ,  kCH , ckey , 
     *       part , ix )
             do 200 i = 1, kCH 
  200        part ( i ) = dlog ( part ( i ))
             call martspar (
     i       '<--' , 'd-weights' , 0 ,
     o       Par , Npar , 
     i       kCH , 1 , part , Ival )  
          end if 
#ifdef    MPI 
          call mpi_bcast ( np , 1 , MPI_INTEGER , 0 , 
     *    MPI_COMM_WORLD , ierr )
          call mpi_bcast ( Par , np , MPI_DOUBLE_PRECISION , 0 , 
     *    MPI_COMM_WORLD , ierr )
#endif 
       end if 
       call martspar (
     i '<--' , 'var' , 0 ,
     o Par , Npar , 
     i Kch , Kch , var , Ival )  
       call martspar (
     i '<--' , 'ar' , 0 , 
     o Par , Npar , 
     i Kch , Kch , Ar , lAGOPT )
       if( nSYS .lt. kCH ) then 
          do 561 i = 1 , MAXCH 
          do 161 j = 1 , MAXCH 
             ar ( i , j , 1) = 0.d0 
             ar ( i , j , 2) = 0.d0 
  161     continue 
  561     continue 
          call martspar (
     i    '-->' , 'var' , 0 ,
     i    Par , Npar , Kch , Kch ,  
     o    var , Ival )  
          call martspar (
     i    '-->' , 'ar' , 0 , 
     i    Par , Npar , Kch , Kch ,  
     o    Ar , lAGOPT )  
       end if 
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:           lano =    51/129/sp2.@990422.@152623 ........
contents    5.6   tarmodel            
c ardock-specific
      subroutine tarmodel (
     i Par , Kch , M , Ir , 
     a A0 )
       implicit real*8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       parameter ( mm1 = 50 , mm2 = 5)
       dimension A0 ( Kch , Kch , M ) , Par ( MAXPAR )
       dimension  dmq2 ( mm1 , mm1) , dmr2 ( mm2 , mm2) ,              
     & dmf ( mm1 , mm1) , dmg ( mm1 , mm2) , dmq ( mm1 , mm1) , 
     & dmr ( mm2 , mm2) ,  
     & qel ( mm1) , rel ( mm2) ,   
     & qel2 ( mm1) , rel2 ( mm2) , 
     & dma ( mm2 , mm1) , dmb ( mm1 , mm1) ,                        
     & dms ( mm1 , mm2) , dmi ( mm1 , mm1) ,                        
     & dmh ( mm2 , mm2) , dmha ( mm2 , mm1) , dmhr2 ( mm2 , mm2) ,      
     & dmqq ( mm1 , mm1) , dmrr ( mm2 , mm2) , dmss ( mm1 , mm2) ,      
     & dmq0 ( mm1 , mm1) , dmr0 ( mm2 , mm2)     
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .................................................................
c      tarmodel 
c      Copyright_OML 1999 M. Ishiguro & Y. Nukata 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('tarmodel', io , stio )
          call showm2 ('I',
     i    ' Builds teleological model(2.28) by',
     i    ' constructing matrix (E.127).')
          call showr ('I','Par' ,  Par ,    1 , 1 , 10)
          call showi ('I','Kch' ,  Kch ,    1 , 1 , 1)
          call showi ('I','M' ,    M ,      1 , 1 , 1)
          call showi ('I','Ir' ,   Ir ,     1 , 1 , 1)
          call showr ('A','A0' ,   A0 ,     Kch , Kch , Kch )    
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       npp = 1 
       sight  =  dexp ( Par ( npp )) 
       if( sight .le. 0) goto 9100 
c      --------------------------
       l = Kch  - Ir 
       mr = M * Ir     
       m1 = mr     
       m2 = l 
       call areachk (
     i 'tarmodel' , 'mm1' , mm1 , m1 , 1 ,
     o ierr )
       call areachk (
     i 'tarmodel' , 'mm2' , mm2 , m2 , 1 ,
     o ierr )
       do 123 i = 1 , Ir  
          if( i .eq. 1) then  
             qel (1) = 1.d0     
          else     
             npp = npp + 1  
             qel ( i )  =  dexp ( Par ( npp )) 
          end if 
          if( qel ( i ) .lt. 0.d0) goto 9100 
  123  continue 
c      --------
       do 124 i = 1 , l     
          npp = npp + 1 
          rel ( i )  =  dexp ( Par ( npp ))   
          if( rel ( i ) .lt. 0.d0) goto 9100 
  124  continue      
c      --------
       call remtsbx (
     i qel , mm1 , mr , Ir , 
     o dmq )
       call remtsbx (
     i rel , mm2 , l , l , 
     o dmr )
       do 125 i = 1 , Ir  
          npp = npp + 1   
          qel2 ( i )  =  dexp ( Par ( npp ))  
          if( qel2 ( i ) .lt. 0.d0) goto 9100 
  125  continue           
c      --------
       do 126 i = 1 , l   
          npp = npp + 1   
          rel2 ( i )  =  dexp ( Par ( npp ))  
          if( rel2 ( i ) .lt. 0.d0) goto 9100   
  126  continue        
c      --------
       call remtsbx (
     i qel2 , mm1 , mr , Ir , 
     o dmq2)                          
       call remtsbx (
     i rel2 , mm2 , l , l , 
     o dmr2)
       im = 0 
       mr = M * Ir 
       do 400 jj = 1 , M 
          do 450 i = 1 , Ir 
             ii = im + i  
             do 401 j = 1 , mr     
                dmf ( ii , j ) = 0.d0 
  401        continue 
             do 500 j = 1 , Ir     
                dmf ( ii , j ) = A0 ( i , j , jj )  
  500        continue 
             if( ii .lt. mr ) dmf ( ii , ii + Ir ) = 1.d0                   
             do 501 j = 1 , l 
                dmg ( ii , j ) = A0 ( i , Ir + j , jj ) 
  501        continue    
  450     continue     
          im = im + Ir 
  400  continue 
       do 10 i = 1 , m1   
       do 20 j = 1 , m2 
          dms ( i , j ) = 0.d0 
   20  continue 
   10  continue 
c      holizen control 1994.11.17 by m.i.
       nhol  =  30 
       do 260 i = 1 , m1  
       do 270 j = 1 , m1 
          dmq0 ( i , j ) = dmq ( i , j ) 
          dmq ( i , j )  =  dmq0 ( i , j ) * sight ** nhol                 
  270  continue 
  260  continue 
       do 280 i = 1 , m2  
       do 290 j = 1 , m2 
          dmr0 ( i , j ) = dmr ( i , j ) 
          dmr ( i , j )  =  dmr0 ( i , j ) * sight ** nhol                   
  290  continue 
  280  continue 
c      -- n kai loop 
       do 30 n = 1 , nhol 
          weight  =  sight ** ( nhol - n + 1)   
          call subabh (
     i    dmq , dms , dmf , dmg , dmq2 , dmr , dmr2 , dmi , weight , 
     i    mm1 , mm2 , m1 , m2 , 
     o    dma , dmb , dmh )                         
          call invmat (
     i    m2 , mm2 , 
     a    dmh , 
     o    deth1 , ier )
          call subqrs (
     i    dma , dmb , dmh , dmr2 , weight , mm1 , mm2 , m1 , m2 , 
     o    dmqq , dmrr , dmss )
          weight  =  sight ** ( nhol -  n ) 
          do 60 i = 1 , m1   
          do 8870 j = 1 , m1 
             dmq ( i , j ) = dmq0 ( i , j ) * weight + dmqq ( i , j )    
 8870     continue 
   60     continue 
          do 80 i = 1 , m2   
          do 90 j = 1 , m2 
             dmr ( i , j ) = dmr0 ( i , j ) * weight + dmrr ( i , j )         
   90     continue 
   80     continue 
          do 100 i = 1 , m1  
          do 110 j = 1 , m2 
             dms ( i , j ) = dmss ( i , j ) 
  110     continue 
  100     continue 
   30  continue 
c      --`h - 1a` keisan 
       do 120 i = 1 , m2  
       do 130 k = 1 , m1 
          dmha ( i , k ) = 0 
  130  continue 
  120  continue 
       do 140 i = 1 , m2  
       do 150 k = 1 , m1 
       do 160 j = 1 , m2 
          dmha ( i , k ) = dmha ( i , k ) + 
     *    dmh ( i , j ) * dma ( j , k )              
  160  continue 
  150  continue 
  140  continue 
c      --`h - 1ar2` keisan   
       do 121 i = 1 , m2  
       do 131 k = 1 , m2 
          dmhr2 ( i , k ) = 0 
  131  continue 
  121  continue 
       do 141 i = 1 , m2  
       do 151 k = 1 , m2 
       do 161 j = 1 , m2 
          dmhr2 ( i , k ) = dmhr2 ( i , k ) + 
     *    dmh ( i , j ) * dmr2 ( j , k )           
  161  continue 
  151  continue 
  141  continue 
       do 1001 i = 1 , M  
          do 1022 j = 1 , l 
          do 1002 k = 1 , Kch 
             A0 ( Ir + j , k , i ) = 0.d0   
             if( i .eq. 1 .and. k .gt. Ir ) 
     *       A0 ( Ir + j , k , i ) = dmhr2 ( j , k - Ir )
 1002     continue 
 1022     continue 
          do 1003 k = i , M 
             ig = ( k - i ) * Ir 
             do 1044 j = 1 , l     
             do 1004 kk = 1 , Kch  
                sum = 0.d0 
                do 1005 jj = 1 , Ir 
                   sum = sum + 
     *             dmha ( j , ig + jj ) * A0 ( jj , kk , k )               
 1005           continue 
                A0 ( Ir + j , kk , i ) = 
     *          A0 ( Ir + j , kk , i ) + sum 
 1004        continue 
 1044        continue 
 1003     continue     
 1001  continue 
       goto 9100 
      end  
#endif

#ifdef ARDOCKLINK
checkpoint:            lano =    52/129/sp2.@990422.@152623 ........
contents    5.7   remtsbx             
c ardock-specific
      subroutine remtsbx (
     i Xel , Mj , Mm , M , 
     o X )                          
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       dimension X ( Mj , Mj ) , Xel (1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ................................................................
c      remtsbx 
c      Copyright_OML 1999 M. Ishiguro & Y. Nukata 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('remtsbx', io , stio )
          call showm ('I',
     i    ' Constructs a diagonal matrix')
          call showr ('I','Xel' , Xel ,   1 , 1 , Mm )
          call showi ('I','Mj' ,  Mj ,    1 , 1 , 1)
          call showi ('I','Mm' ,  Mm ,    1 , 1 , 1)
          call showi ('I','M' ,   M ,     1 , 1 , 1)
          call showr ('O','X' ,  X ,    Mj , Mm , Mm )    
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 10 i = 1 , Mm   
          do 11 j = 1 , Mm 
             X ( i , j ) = 0.d0 
   11     continue 
          if( i .le. M ) X ( i , i ) = Xel ( i )
   10  continue 
       goto 9100 
      end  
#endif

#ifdef ARDOCKLINK
checkpoint:             lano =    53/129/sp2.@990422.@152623 ........
contents    5.8   subabh              
c ardock-specific
      subroutine subabh (
     i Dmq , Dms , Dmf , Dmg , Dmq2 , Dmr , Dmr2 , Dmi , Weight ,
     i Mm1 , Mm2 , M1 , M2 , 
     o Dma , Dmb , Dmh )                
       implicit real*8 ( a-h , o-z )  
#include "ardock.env"
       parameter ( l1 = 50 , l2 = 5) 
       dimension Dmq ( Mm1 , mm1) , Dms ( Mm1 , mm2) , 
     & Dmf ( Mm1 , mm1) ,         
     & Dmg ( Mm1 , mm2) , Dma ( Mm2 , mm1) , Dmb ( Mm1 , mm1) ,         
     & Dmq2 ( Mm1 , mm1) , Dmh ( Mm2 , mm2) ,                       
     & Dmr ( Mm2 , mm2) , Dmr2 ( Mm2 , mm2) , Dmi ( Mm1 , mm1)       
       dimension  trafi ( l1 , l1) , 
     & dmgq ( l2 , l1) , dmgq2 ( l2 , l1) , dmgqf ( l2 , l1) , 
     & dmsf ( l2 , l1) ,    
     & dmfq ( l1 , l1) , dmfqf ( l1 , l1) , dmfiw ( l1 , l1) , 
     & dmfwf ( l1 , l1) ,   
     & dmgqg ( l2 , l2) , dmgs ( l2 , l2) , dmsg ( l2 , l2)           
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data jonce  / 0 /  
c      ...................................................................
c      subabh 
c      Copyright_OML 1999 M. Ishiguro & Y. Nukata  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      c ----- subroutine --- "a" , "b" , "h"  keisan --- c                  
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subabh', io , stio )
          call showm ('I',
     i    ' Computes eqs.(E.117) and (E.118) of CSM.')
          call showr ('I','Dmq' ,   Dmq ,     Mm1 , M1 , M1 )    
          call showr ('I','Dms' ,   Dms ,     Mm1 , M1 , M2 )
          call showr ('I','Dmf' ,   Dmf ,     Mm1 , M1 , M1 )
          call showr ('I','Dmg' ,   Dmg ,     Mm1 , M1 , M2 )
          call showr ('I','Dmq2' ,  Dmq2 ,    Mm1 , M1 , M1 )
          call showr ('I','Dmr' ,   Dmr ,     Mm2 , M2 , M2 )
          call showr ('I','Dmr2' ,  Dmr2 ,    Mm2 , M2 , M2 )
          call showr ('I','Dmi' ,   Dmi ,     Mm1 , M1 , M1 )
          call showr ('I','Weight' ,Weight ,  1 , 1 , 1)
          call showi ('I','Mm1' ,   Mm1 ,     1 , 1 , 1)
          call showi ('I','Mm2' ,   Mm2 ,     1 , 1 , 1)
          call showi ('I','M1' ,    M1 ,      1 , 1 , 1)
          call showi ('I','M2' ,    M2 ,      1 , 1 , 1)
          call showr ('O','Dma' ,  Dma ,     Mm2 , M2 , M1 )    
          call showr ('O','Dmb' ,  Dmb ,     Mm1 , M1 , M1 )
          call showr ('O','Dmh' ,  Dmh ,     Mm2 , M2 , M2 )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( jonce .eq. 0) then 
          call areachk (
     i    'subabh' , 'l1' , l1 , M1 , 1 ,
     o    ierr )
          call areachk (
     i    'subabh' , 'l2' , l2 , M2 , 1 ,
     o    ierr )
          jonce = 1 
       end if 
       do 1 i = 1 , M1     
          do 2 j = 1 , M1  
             trafi ( i , j ) = Dmf ( j , i )
             if( i .eq. j ) then 
                trafi ( i , j ) = trafi ( i , j ) - 1.d0 
             end if 
             dmfq ( i , j ) = 0.d0 
             dmfqf ( i , j ) = 0.d0     
             dmfiw ( i , j ) = 0.d0     
             dmfwf ( i , j ) = 0.d0     
    2     continue 
    1  continue 
       do 3 i = 1 , M2     
       do 4 j = 1 , M1  
          dmgq ( i , j ) = 0.d0 
          dmgq2 ( i , j ) = 0.d0     
          dmgqf ( i , j ) = 0.d0     
          dmsf ( i , j ) = 0.d0 
    4  continue 
    3  continue 
       do 100 i = 1 , M2  
       do 200 j = 1 , M2 
          dmgqg ( i , j ) = 0.d0     
          dmgs ( i , j ) = 0.d0 
          dmsg ( i , j ) = 0.d0 
  200  continue 
  100  continue 
c      ------- "a" keisan   
       do 5 i = 1 , M2     
       do 6 k = 1 , M1  
       do 87 j = 1 , M1 
           dmgq ( i , k ) = dmgq ( i , k ) + Dmg ( j , i ) * 
     *     ( Dmq ( j , k ) + Weight  *  Dmq2 ( j , k ))
   87  continue   
    6  continue 
    5  continue 
       do 8 i = 1 , M2     
       do 9 k = 1 , M1  
          do 10 j = 1 , M1 
             dmgqf ( i , k ) = dmgqf ( i , k ) + dmgq ( i , j ) * 
     *       Dmf ( j , k )           
             dmsf ( i , k ) = dmsf ( i , k ) +  Dms ( j , i ) * 
     *       Dmf ( j , k ) 
             dmgq2 ( i , k ) = dmgq2 ( i , k ) +  Dmg ( j , i ) * 
     *       Dmq2 ( j , k ) *  Weight  
   10     continue   
          Dma ( i , k ) =  - ( dmgqf ( i , k ) + dmsf ( i , k ) - 
     *    dmgq2 ( i , k ))       
    9  continue 
    8  continue 
c      ------- "b" keisan   
       do 11 i = 1 , M1   
       do 12 k = 1 , M1 
       do 13 j = 1 , M1 
          dmfq ( i , k ) = dmfq ( i , k ) +  
     *    Dmf ( j , i ) * Dmq ( j , k )      
          dmfiw ( i , k ) = dmfiw ( i , k ) +  trafi ( i , j ) *  
     *    Dmq2 ( j , k ) *  Weight 
   13  continue 
   12  continue 
   11  continue 
       do 14 i = 1 , M1   
       do 15 k = 1 , M1 
          do 16 j = 1 , M1 
             dmfqf ( i , k ) = dmfqf ( i , k ) + dmfq ( i , j ) * 
     *       Dmf ( j , k )
             dmfwf ( i , k ) = dmfwf ( i , k ) + dmfiw ( i , j ) * 
     *       ( Dmf ( j , k ) - Dmi ( j , k ))     
   16     continue   
          Dmb ( i , k ) = dmfqf ( i , k ) + dmfwf ( i , k )     
   15  continue 
   14  continue 
c      ------- "h" keisan   
       do 20 i = 1 , M2   
       do 21 k = 1 , M2 
          do 22 j = 1 , M1 
             dmgqg ( i , k ) = dmgqg ( i , k ) +  dmgq ( i , j ) * 
     *       Dmg ( j , k )           
             dmgs ( i , k ) = dmgs ( i , k ) +  Dmg ( j , i ) * 
     *       Dms ( j , k )  
             dmsg ( i , k ) = dmsg ( i , k ) +  Dms ( j , i ) * 
     *       Dmg ( j , k )
   22     continue   
          Dmh ( i , k ) = dmgqg ( i , k ) + dmgs ( i , k ) + 
     *    dmsg ( i , k ) + Dmr ( i , k ) + Weight  *  Dmr2 ( i , k ) 
   21  continue 
   20  continue 
       goto 9100 
      end  
#endif

#ifdef ARDOCKLINK
checkpoint:              lano =    54/129/sp2.@990422.@152623 ........
contents    5.9   subqrs              
c ardock-specific
      subroutine subqrs (
     i Dma , Dmb , Dmh , Dmr2 , Weight , Mm1 , Mm2 , M1 , M2 , 
     o Dmqq , Dmrr , Dmss )   
       implicit real*8 ( a-h , o-z )  
#include "ardock.env"
       parameter ( l1 = 50 , l2 = 5) 
       dimension Dma ( Mm2 , mm1) , Dmb ( Mm1 , mm1) , 
     & Dmh ( Mm2 , mm2) , 
     & Dmr2 ( Mm2 , mm2) , dmah ( l1 , l2) , dmaha ( l1 , l1) , 
     & dmrh ( l2 , l2) ,    
     & dmrhr ( l2 , l2) , Dmqq ( Mm1 , mm1) , Dmrr ( Mm2 , mm2) , 
     & Dmss ( Mm1 , mm2)     
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data jonce  / 0 /  
c      .................................................................
c      subqrs 
c      Copyright_OML 1999 M. Ishiguro & Y. Nukata 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      c ----- subroutine -- "qq" , "rr" , "ss" keisan -- c                  
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subqrs', io , stio )
          call showm ('I',
     i    ' Computes eq.(E.125) of CSM.')
          call showr ('I','Dma' ,   Dma ,    Mm2 , M2 , M1 )    
          call showr ('I','Dmb' ,   Dmb ,    Mm1 , M1 , M1 )
          call showr ('I','Dmh' ,   Dmh ,    Mm2 , M2 , M2 )
          call showr ('I','Dmr2' ,  Dmr2 ,   Mm2 , M2 , M2 )
          call showr ('I','Weight' ,Weight , 1 , 1 , 1)
          call showi ('I','Mm1' ,   Mm1 ,    1 , 1 , 1)
          call showi ('I','Mm2' ,   Mm2 ,    1 , 1 , 1)
          call showi ('I','M1' ,    M1  ,    1 , 1 , 1)
          call showi ('I','M2' ,    M2  ,    1 , 1 , 1)
          call showr ('O','Dmqq' ,  Dmqq ,   Mm1 , M1 , M1 )
          call showr ('O','Dmrr' ,  Dmrr ,   Mm2 , M2 , M2 )
          call showr ('O','Dmss' ,  Dmss ,   Mm1 , M1 , M2 )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( jonce .eq. 0) then 
          call areachk (
     i    'subqrs' , 'l1' , l1 , M1 , 1 ,
     o    ierr )
          call areachk (
     i    'subqrs' , 'l2' , l2 , M2 , 1 ,
     o    ierr )
          jonce = 1 
       end if 
       do 100 i = 1 , M1  
       do 200 j = 1 , M2 
          dmah ( i , j ) = 0.d0 
          Dmss ( i , j ) = 0.d0 
  200  continue 
  100  continue 
       do 250 i = 1 , M1  
       do 260 j = 1 , M1 
          dmaha ( i , j ) = 0.d0     
  260  continue 
  250  continue 
       do 270 i = 1 , M2  
       do 280 j = 1 , M2 
          dmrh ( i , j ) = 0.d0 
          dmrhr ( i , j ) = 0.d0     
  280  continue 
  270  continue 
c      ------- "qq" keisan  
       do 300 i = 1 , M1  
       do 400 k = 1 , M2 
       do 500 j = 1 , M2     
          dmah ( i , k ) = dmah ( i , k ) + 
     *    Dma ( j , i ) * Dmh ( j , k )            
  500  continue   
  400  continue 
  300  continue 
       do 600 i = 1 , M1  
       do 801 k = 1 , M1 
          do 800 j = 1 , M2 
             dmaha ( i , k ) = dmaha ( i , k ) + dmah ( i , j ) * 
     *       Dma ( j , k )           
  800     continue   
          Dmqq ( i , k ) = Dmb ( i , k ) - dmaha ( i , k )    
  801  continue 
  600  continue 
c      ------- "rr" keisan  
       do 900 i = 1 , M2  
       do 1000 k = 1 , M2 
       do 1100 j = 1 , M2 
          dmrh ( i , k ) = dmrh ( i , k ) + Dmr2 ( i , j ) * 
     *    Dmh ( j , k ) * Weight     
 1100  continue   
 1000  continue 
  900  continue 
       do 1200 i = 1 , M2 
       do 1300 k = 1 , M2 
          do 1400 j = 1 , M2 
             dmrhr ( i , k ) = dmrhr ( i , k ) + dmrh ( i , j ) * 
     *       Dmr2 ( j , k ) * Weight 
 1400     continue   
          Dmrr ( i , k ) = Weight * Dmr2 ( i , k ) - dmrhr ( i , k )                
 1300  continue 
 1200  continue 
c      ------- "ss" keisan  
       do 1500 i = 1 , M1 
       do 1600 k = 1 , M2 
       do 1700 j = 1 , M2 
          Dmss ( i , k ) = Dmss ( i , k ) - dmah ( i , j ) * 
     *    Dmr2 ( j , k ) * Weight    
 1700  continue   
 1600  continue 
 1500  continue 
       goto 9100 
      end 
#endif

checkpoint:               lano =    55/129/sp2.@990422.@152623 ........
contents  6. ready                subpackage
contents    6.1   ready               
c reusable
      subroutine ready (
     i Mt )    
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       character*80 a , b 
       data a  / 'DATASTARTINGLINE' / 
c      ........................................................
c      ready 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('ready', io , stio )
          call showm ('I',
     i    ' Searches for the data body in a file.')
          call showi ('I','Mt' , Mt , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9199  continue 
       write(6 , 605) Mt 
  605  format(1x , 'missing DATASTARTINGLINE in unit' , i3)     
       call mpistop (1) 
c      ============  
 9200  continue     
       io = 'O'
       write(6 , 601) Mt 
  601  format(1x , 'file opener started for unit' , i5)  
    1  read ( Mt , '(A)' , end = 9199) b 
c      ----------------------- 
       write(6 , 600) b 
  600  format(1x , a80) 
       if( a (1:16) .ne. b (1:16)) goto 1 
c      ------------------------------- 
       goto 9100    
      end 

checkpoint:                lano =    56/129/sp2.@990422.@152623 ........
contents    6.2   maskrs              
c reusable
      subroutine maskrs (
     i Kch , 
     o Mask )
       dimension Mask ( Kch , Kch )  
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      maskrs 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('maskrs', io , stio )
          call showm ('I',
     i    ' Resets mask C in eq.(3.61).')
          call showi ('I','Kch' ,  Kch ,     1 , 1 , 1)
          call showi ('O','Mask' ,  Mask ,   Kch , Kch , Kch )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 11 i = 1 , Kch     
       do 1 j = 1 , Kch     
       Mask ( j , i ) = 1 
    1  continue 
   11  continue                   
       goto 9100 
      end  

checkpoint:                 lano =    57/129/sp2.@990422.@152623 ........
contents  7. pwspx                subpackage
contents    7.1   pwspx               
c reusable
      subroutine pwspx (
     i Var , Ar , Tscale , Rangl , Rangh , Kch , Lag , Nblock , Ib , 
     i Mask , 
     o Power , Coherency )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Var ( Kch , Kch ) , Ar ( Kch , Kch , MAXLAG)
       dimension Coherency ( MAXF  + 1, Kch , Kch )
       dimension Ib ( Nblock )
       dimension hhcx (2 , MAXCH , MAXCH * 2)
       dimension g ( MAXLAG + 1) , 
     * Power ( MAXF + 1 , Kch  + 1 , Kch ) ,
     * Mask ( Kch , Kch )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      pwspx 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pwspx', io , stio )
          call showm ('I',
     i    ' Computes power spectrum(3.40) of CSM.')
          call showr ('I','Var' ,      Var ,     Kch , Kch , Kch )    
          call showr ('I','Ar' ,       Ar ,      Kch , Kch , Kch )
          call showr ('I','Tscale' ,   Tscale ,  1 , 1 , 1)     
          call showr ('I','Rangl' ,    Rangl ,   1 , 1 , 1)
          call showr ('I','Rangh' ,    Rangh ,   1 , 1 , 1)
          call showi ('I','Kch' ,      Kch ,     1 , 1 , 1)
          call showi ('I','Lag' ,      Lag ,     1 , 1 , 1)
          call showi ('I','Nblock' ,   Nblock ,  1 , 1 , 1)
          call showi ('I','Ib' ,       Ib ,      1 , 1 , Nblock )
          call showi ('I','Mask' ,     Mask ,    Kch , Kch , Kch )
          call showr ('O','Power' ,    Power ,   MAXF + 1 , 
     *    MAXF + 1 , Nblock )
          call showr ('O','Coherency', Coherency , MAXF + 1 , 
     *    MAXF + 1 , Kch )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       cf = MAXF 
       af0  =  ( Rangh - Rangl ) / cf 
       do 10 jf = 1 , MAXF + 1     
          do 40 ii = 1 , Kch   
          do 41 jj = 1 , Kch 
             if( ii .eq. jj ) then     
                g (1) = 1.d0 
             else 
                g (1) = 0.d0 
             endif 
             do 45 i = 1 , Lag 
                i1 = i + 1     
                if( ii .ne. jj ) then 
                   g ( i1) =  - Ar ( ii , jj , i ) * Mask ( ii , jj ) 
                else 
                   g ( i1) =  - Ar ( ii , jj , i )  
                end if 
   45        continue     
   44        lg = Lag     
             af  =  af0 * ( jf - 1) + Rangl 
             call fouge1 ( g , af , lg + 1 , fck , fsk ) 
             hhcx (1 , ii , jj ) = fck 
             hhcx (2 , ii , jj ) = fsk 
             hhcx (2 , ii , jj +  Kch ) = 0.d0 
             if( ii .eq. jj ) then 
                hhcx (1 , ii , jj +  Kch ) = 1.d0 
             else 
                hhcx (1 , ii , jj +  Kch ) = 0.d0 
             end if 
   41     continue   
   40     continue 
c         relative power contributions computation 
          call cxhushld (
     i    MAXCH , Kch , Kch  * 2 , 
     a    hhcx )
corrected2000.11.21 this subroutine call is modified by M.I.
          call cxsolve (
     i    MAXCH , Kch , Kch  * 2 , -1 , 
     a    hhcx , 
     o    ierr )
          call subcoh (
     i    hhcx (1 , 1 , Kch  + 1) , Var , Mask , Kch , Nblock , Ib ,
     i    jf , 
     o    Coherency )
          call subnosx (
     i    hhcx (1 , 1 , Kch  + 1) , Var , Mask , Kch , Nblock , Ib ,
     i    jf , 
     o    Power )
   10  continue 
       goto 9100 
      end 

checkpoint:                  lano =    58/129/sp2.@990422.@152623 ........
contents    7.2   subnosx             
c reusable
      subroutine subnosx (
     i Hhcx , Var , Mask , Kch , Nblock , Ib , Jf , 
     o Power )
       implicit real*8 ( a-h , o-z )     
#include "ardock.env"
       dimension Hhcx (2 , MAXCH , MAXCH ) , Mask ( Kch , Kch )
       dimension Var ( Kch , Kch ) , 
     * Power ( MAXF + 1 , Kch  + 1 , Kch )
       dimension Sqrvar ( MAXCH ) , Ib ( Nblock )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      subnosx          
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine computes relative power contributions. 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subnosx', io , stio )
          call showm ('I',
     i    'Computes relative power contribution (3.49) of CSM.')
          call showr ('I','Hhcx' ,  Hhcx ,    2 , 2 , Kch )     
          call showr ('I','Var' ,   Var ,     Kch , Kch , Kch )    
          call showi ('I','Mask' ,  Mask ,    Kch , Kch , Kch )
          call showi ('I','Kch' ,   Kch ,     1 , 1 , 1)
          call showi ('I','Nblock', Nblock ,  1 , 1 , 1)
          call showi ('I','Ib' ,    Ib ,      1 , 1 , Nblock )
          call showi ('I','Jf' ,    Jf ,      1 , 1 , 1)
          call showr ('O','Power',  Power ,   MAXF + 1 , 
     *    MAXF + 1 , Nblock )     
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 10 ii = 1 , Kch 
          sum = 0.d0     
          je = 0 
          do 111 jgrp = 1 , Nblock  
             sum1 = 0.d0   
             js = je + 1  
             je = Ib ( jgrp )
             do 11 jj = js , je 
                sumr = 0.d0 
                sumi = 0.d0     
                do 13 kk = js , je 
                   rx = Hhcx (1 , ii , kk ) 
                   rix = Hhcx (2 , ii , kk )
                   sumr  =  sumr + rx  *  Var ( jj , kk ) *  
     *             Mask ( jj , jj )  *  Mask ( kk , kk ) 
                   sumi  =  sumi + rix  *  Var ( jj , kk ) *  
     *             Mask ( jj , jj )  *  Mask ( kk , kk )
   13           continue 
                sum1  =  sum1 + sumr  *  Hhcx (1 , ii , jj ) + 
     *          sumi  *  Hhcx (2 , ii , jj )  
   11        continue 
             sum  =  sum + sum1 
             Sqrvar ( jgrp )  =  sum 
  111     continue 
          if( sum .gt. 0.d0) then 
             rconst  =  1.d0 /  sum 
          else  
             rconst  =  1.d0 
          end if   
          do 12 ll = 1 , Nblock 
             Power ( Jf , ll , ii ) =  Sqrvar ( ll ) *  rconst 
   12     continue 
          Power ( Jf , Nblock , ii ) =  sum 
   10  continue 
       goto 9100 
      end 

checkpoint:                   lano =    59/129/sp2.@990422.@152623 ........
contents    7.3   subcoh              
c reusable
      subroutine subcoh (
     i Hhcx , Var , Mask , Kch , Nblock , Ib , Jf , 
     o Coherency )
       implicit real*8 ( a-h , o-z )     
#include "ardock.env"
       dimension Hhcx (2 , MAXCH , MAXCH ) , Mask ( Kch , Kch )
       dimension Var ( Kch , Kch ) 
       dimension Coherency ( MAXF + 1 , Kch , Kch )
       dimension Ib ( Nblock )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      subcoh          
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine computes relative power contributions. 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subcoh', io , stio )
          call showm ('I',
     i    ' Computes choherency (3.43) of CSM.')
          call showr ('I','Hhcx' ,     Hhcx ,     2 , 2 , Kch )     
          call showr ('I','Var' ,      Var ,      Kch , Kch , Kch )    
          call showi ('I','Mask' ,     Mask ,     Kch , Kch , Kch )
          call showi ('I','Kch' ,      Kch ,      1 , 1 , 1)
          call showi ('I','Nblock' ,   Nblock ,   1 , 1 , 1)
          call showi ('I','Ib' ,       Ib ,       1 , 1 , Nblock )
          call showi ('I','Jf' ,       Jf ,       1 , 1 , 1)
          call showr ('O','Coherency', Coherency , 
     *    MAXF + 1, MAXF + 1,2 * Kch )     
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 9  i9 = 1 , Kch 
       do 10 ii = 1 , i9 
          sumr = 0.d0 
          sumi = 0.d0     
          je = 0 
          do 111 jgrp = 1 , Nblock  
             js = je + 1  
             je = Ib ( jgrp )
             do 11 jj = js , je 
                rx = Hhcx (1 , ii , jj ) 
                rix = Hhcx (2 , ii , jj )
                do 13 kk = js , je 
                   rx9 = Hhcx (1 , i9 , kk ) 
                   rix9 = - Hhcx (2 , i9 , kk )
                   sumr  =  sumr + ( rx  *  rx9 - rix  *  rix9 )  *  
     *             Var ( jj , kk )
                   sumi  =  sumi + ( rix  *  rx9 + rix9  *  rx )  * 
     *             Var ( jj , kk )
   13           continue 
   11        continue 
  111     continue 
          Coherency ( Jf , i9 , ii ) =  sumr  *  * 2 + sumi  *  *  2 
   10  continue 
       Coherency ( Jf , i9 , i9 ) =  sqrt( Coherency ( Jf , i9 , i9 )) 
    9  continue 
       do 29 i9 =1, Kch 
       do 20 ii = i9 + 1, Kch 
          Coherency ( Jf , ii , i9 ) =  Coherency ( Jf , ii , i9 ) / 
     *    Coherency ( Jf , ii , ii )  /   Coherency ( Jf , i9 , i9 )
          Coherency ( Jf , i9 , ii ) =  Coherency ( Jf , ii , i9 )
   20  continue 
       Coherency ( Jf ,i9 , i9 )= 1.d0 
   29  continue 
       goto 9100 
      end 

checkpoint:                    lano =    60/129/sp2.@990422.@152623 ........
contents  8. pwevol               subpackage
contents    8.1   pwevol              
c reusable
      subroutine pwevol (
     i Var , Ar , Lag , Kch , Ndata , Mask , 
     o Pbp , Scale )
       implicit real*8 ( a-h , o-z )   
#include "ardock.env"
       parameter (mxz = MAXCH * MAXLAG)                       
       dimension Ar ( Kch , Kch , Lag ) , Var ( Kch , Kch )
       dimension Mask ( Kch , Kch )             
       dimension  Pbp ( MAXN , MAXCH ) ,  g ( mxz , MAXCH )
       dimension  qd ( MAXCH , MAXCH ) , Scale ( Kch )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      pwevol 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          iw0 = iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pwevol', io , stio )                  
          call showm3 ('I',
     i    ' Constructs the recursion equation(3.36)',
     i    ' and computes power building profile(3.35) and',
     i    ' scaling factor(3.42).')
          call showr ('I','Var' ,   Var ,     Kch , Kch , Kch )
          call showr ('I','Ar' ,    Ar ,      Kch , Kch , Kch )     
          call showi ('I','Lag' ,   Lag ,     1 , 1 , 1)
          call showi ('I','Kch' ,   Kch ,     1 , 1 , 1)    
          call showi ('I','Ndata' , Ndata ,   1 , 1 , 1)
          call showi ('I','Mask' ,  Mask ,    Kch , Kch , Kch )    
          call showr ('O','Pbp' ,   Pbp ,     MAXN , N , Kch )
          call showr ('O','Scale' , Scale ,   1 , 1 , Kch )     
          call selfend ( myself , io , inisub )
       end if 
#endif
check CONNECT
       if( io .ne. 'O') then
          iz = Lag * Kch 
          maxl  =  Kch *  * 2 * Lag + iz - Kch 
catch-    call nw
          nw0 = nw ('{' , 0)
          iw0 = iw ('{' , 0)
          nwvf = nw ('vf' , maxl )
          iwirf = iw ('irf' , maxl )
          iwicf = iw ('icf' , maxl )
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
       N = Ndata 
       if( N .gt. 100) N = 100   
       call llset (
     i Var , Ar , Mask , Lag , Kch , iz , 
     o g , qd , 
     o wk ( nwvf ) , iwk ( iwirf ) , iwk ( iwicf ) , nf )        
       call pwprof (
     i g , qd , wk ( nwvf ) , iwk ( iwirf ) , iwk ( iwicf ) , nf , 
     i Kch , iz , N , 
     o Pbp ) 
       do 1 i = 1 , Kch 
          Scale ( i ) = Pbp ( N , i )
    1  continue 
       goto 9100 
      end  

checkpoint:                     lano =    61/129/sp2.@990422.@152623 ........
contents    8.2   pwprof              
c reusable
      subroutine pwprof (
     i G , Qd , Vf , Irf , Icf , Nf , Iq , Iz , N , 
     o P )    
       implicit real*8 ( a-h , o-z )  
#include "ardock.env"
       parameter ( mxz = MAXCH * MAXLAG)                       
       dimension  P ( MAXN , MAXCH ) ,  G ( Iz , Iq ) ,
     * p1 ( mxz , mxz ) , p2 ( mxz , mxz )
       dimension  Qd ( Iq , Iq ) , qq ( mxz , mxz )                           
       dimension Icf ( Nf ) , Irf ( Nf ) , Vf ( Nf ) 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      pwprof 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('pwprof', io , stio )                  
          call showm ('I',
     i    ' Computes power building profile(3.35).')
          call showr ('I','G' ,   G ,       Iz , Iz , Iq )
          call showr ('I','Qd' ,  Qd ,      Iq , Iq , Iq )
          call showr ('I','Vf' ,  Vf ,      1 , 1 , Nf )    
          call showi ('I','Irf' , Irf ,     1 , 1 , Nf )    
          call showi ('I','Icf' , Icf ,     1 , 1 , Nf )
          call showi ('I','Nf' ,  Nf ,      1 , 1 , 1)
          call showi ('I','Iq' ,  Iq ,      1 , 1 , 1)
          call showi ('I','Iz' ,  Iz ,      1 , 1 , 1)    
          call showi ('I','N ' ,  N ,       1 , 1 , 1)
          call showr ('O','P' ,   P ,       MAXN , MAXN , MAXCH )
          call selfend ( myself , io , inisub )    
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 1000 i = 1 , Iz 
          do 1001 j = 1 , i 
             p1 ( i , j ) = 0.d0 
             p1 ( j , i ) = 0.d0  
 1001     continue                      
          do 1002 j = 1 , i 
             sum = 0.d0 
             do 5003 l = 1 , Iq   
             do 1003 m = 1 , Iq   
                sum = sum + G ( i , l ) * Qd ( l , m ) * G ( j , m )
 1003        continue 
 5003        continue 
             qq ( i , j ) = sum 
             if( j.lt.i ) qq ( j , i ) = sum 
 1002     continue            
 1000  continue     
       do 2000 k = 1 , N  
          do 5200 i = 1 , Iz 
          do 2200 j = 1 , Iz 
             p2 ( i , j ) = qq ( i , j )
 2200     continue 
 5200     continue 
          call both (
     i    Vf , p1 , mxz , mxz , Nf , Irf , Icf , mxz , mxz , 
     a    p2)       
          do 5201 i = 1 , Iz 
          do 2201 j = 1 , Iz 
             p1 ( i , j ) = p2 ( i , j )
 2201    continue 
 5201    continue 
         do 2202 i = 1 , iq 
            P ( k , i ) = p2 ( i , i )  
 2202    continue                    
 2000  continue 
       goto 9100 
      end  

checkpoint:                    lano =    62/129/sp2.@990422.@152623 ........
contents    8.3   llset               
c reusable
      subroutine llset (
     i Var , Ar , Mask , Lag , Kch , Iz ,  
     o G , Qd , Vf , Irf , Icf , Nf )                         
       implicit real*8 ( a-h , o-z )  
#include "ardock.env"
       dimension  Ar ( Kch , Kch , Lag ), Mask ( Kch , Kch ), 
     * Var ( Kch , Kch ) 
       dimension  G ( Iz , Kch )     
       dimension  Qd ( Kch , Kch )   
       dimension Icf (1) , Irf (1) , Vf (1)                    
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      llset 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed. 
       Nf = 0 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('llset', io , stio )                  
          call showm2 ('I',
     i    ' Constructs the state transition matrix $\Psi$ in',
     i    ' eq.(3.36) of CSM.')
          call showr ('I','Var' , Var ,    Kch , Kch , Kch )    
          call showr ('I','Ar' ,  Ar ,     Kch , Kch , Kch )     
          call showi ('I','Mask', Mask ,   Kch , Kch , Kch )
          call showi ('I','Lag' , Lag ,    1 , 1 , 1)
          call showi ('I','Kch' , Kch ,    1 , 1 , 1)
          call showi ('I','Iz' ,  Iz ,     1 , 1 , 1)    
          call showr ('O','G' ,   G ,      Iz , Iz , Kch )
          call showr ('O','Qd' ,  Qd ,     Kch , Kch , Kch )    
          call showr ('O','Vf' ,  Vf ,     1 , 1 , Nf )
          call showi ('O','Irf' , Irf ,    1 , 1 , Nf )    
          call showi ('O','Icf' , Icf ,    1 , 1 , Nf )     
          call showi ('O','Nf' ,  Nf ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 33 i = 1 , Iz     
       do 3 j = 1 , Kch     
          G ( i , j ) = 0.d0     
          if( i .eq. j ) G ( i , j ) = Mask ( i , i )
    3  continue 
   33  continue 
       do 55 i = 1 , Kch     
       do 5 j = 1 , Kch     
          Qd ( i , j ) = Var ( i , j )
    5  continue 
   55  continue              
       do 69 i = 1 , Lag     
       do 59 j = 1 , Kch   
       do 19 k = 1 , Kch   
          if( j .ne. k .and. Mask ( j , k ) .eq. 0) goto 119            
          if( Ar ( j , k , i ) .eq. 0.d0)              goto 119      
c         --------------------------------------------
          Nf = Nf  + 1 
          Irf ( Nf ) = j 
          Icf ( Nf ) = ( i - 1) * Kch + k   
          Vf ( Nf ) = Ar ( j , k , i )
  119     continue 
   19  continue 
   59  continue 
   69  continue 
       do 20 i = 1 , Iz - Kch 
          Nf = nf + 1 
          Irf ( Nf ) = i + Kch   
          Icf ( Nf ) = i 
          Vf ( Nf ) = 1.d0 
   20  continue 
       goto 9100 
      end  

checkpoint:                   lano =    63/129/sp2.@990422.@152623 ........
contents  9. lgraph               subpackage
contents    9.1   lgraph              
c reusable
      subroutine lgraph (
     i X , Ixn , Xmis , Cxlab , Xnorm , Xmin0 , Xmax0 , 
     i T0 , Tunit , Ctlab , Ixnlim , Iskip0 )
       implicit real * 8  ( a - h,o - z )
#include "ardock.env"
       character*(*) Cxlab , Ctlab                                    
       dimension X ( Ixn ) ,  axis (11)    
       character*4  l (101) , lform (7) , l0 (101) 
       character*4  lformb (35) , l2x , lb , lx , li , la   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data lformb  / 9*' ','10.2','11.2','12.2','13.2','14.2','15.2', 
     * '16.2','17.2','18.2','19.2','20.2','21.2','22.2','23.2','24.2',    
     * '25.2','26.2','27.2','28.2','29.2','30.2','31.2','32.2','33.2', 
     * '34.2','35.2' /    
       data lpsize /61/, lform /'(1H ',',15X',',F10','.2  ',',10F',
     * '10.2',')   '/   
       data l2x /',1X '/ 
       data lb /'    '/,  lx /'X   '/,  li /'!   '/
       data la /'*   '/  
c      ........................................................
c      lgraph 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      this subroutine prints out the graph of time series x. 
c      data with values greater than or equal to Xmis 
c      are ignored.    
c      history:  Lower bound for the scaling was introduced. 1991.7 
c      completely refreshed 1998.7 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('lgraph', io , stio )
          call showm ('I',
     i    ' Displays time series on the character display. ')
          call showr ('I','X' ,     X      , 1 , 1 , Ixn )
          call showi ('I','Ixn' ,   Ixn    , 1 , 1 , 1)
          call showr ('I','Xmis' ,  Xmis   , 1 , 1 , 1)
          call showc ('I','Cxlab' , Cxlab  , 1 , 1 , 1)
          call showr ('I','Xnorm' , Xnorm  , 1 , 1 , 1)
          call showr ('I','Xmin0' , Xmin0  , 1 , 1 , 1)
          call showr ('I','Xmax0' , Xmax0  , 1 , 1 , 1)
          call showr ('I','T0' ,    T0     , 1 , 1 , 1)
          call showr ('I','Tunit' , Tunit  , 1 , 1 , 1)
          call showc ('I','Ctlab' , Ctlab  , 1 , 1 , 1)
          call showi ('I','Ixnlim' ,Ixnlim , 1 , 1 , 1)
          call showi ('I','Iskip0' ,Iskip0 , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       n  =  Ixn 
       if( Iskip0 .eq. 0) then 
         iskip  =  ( Ixn - 1) / Ixnlim + 1 
       else 
         if( n .gt. Ixnlim ) n  =  Ixnlim 
         iskip = 1 
       end if                                                                
       lform (2) = l2x                                                    
c      :
       xmax  =  Xmax0 
       xmin  =  Xmin0 
       if( xmax .le. xmin ) then 
          xmax  =   - 1.d50 
          xmin  =  1.d50 
          do 10  i = 1 , n 
            if( Xmis .le. 0.d0 .or. X ( i ) .le. Xmis ) then 
               xtem  =  X ( i ) / Xnorm 
               if( xtem .gt. xmax )   xmax  =  xtem 
               if( xtem .lt. xmin )   xmin  =  xtem 
            end if 
   10    continue 
       end if 
c      :                                                              
       xdif  =  xmax - xmin                                              
       if( xdif .le. 1.d0) xdif = 1.d0                                    
c      :                                                              
       power  =  dlog10 ( xdif )                                            
       ix = lftint ( power )                                                
       power  =  10.d0 ** ix                                               
       xdifn  =  xdif  / power                                             
c      :                                                              
       u  =  0.25d0                                                      
       if( xdifn .ge. 1.25d0) u = 0.5d0                                   
       if( xdifn .ge. 2.5d0) u = 1.d0                                     
       if( xdifn .ge. 5.0d0) u = 2.d0                                     
c      :                                                              
       unit  =  u  *  power                                                
       num  =  xdif / unit 
c      1998.7.10                                                 
       itest = 1 
       if( itest .eq. 0) then 
          num = num + 2 
       else 
          num2  =  num / 2 + 1 
          num = num2 * 2 
       end if                                                      
       lp  =  lpsize / num                                                 
       mesh  =  lp * num                                                   
       lpmax = mesh + 1                                                  
       if( xmin .ge. 0.d0) ixmin  =  xmin / unit                            
       if( xmin .lt. 0.d0) ixmin  =  xmin / unit - 1                        
       xmin  =  ixmin * unit                                               
       if( xmin + num * unit .lt. xmax ) num = num + 1 
       xmax  =  xmin + num * unit                                          
c      :                                                              
       xd  =  ( xmax - xmin ) / mesh                                           
       xd2  =  xd * 0.5                                                    
       xd10  =  xd * lp                                                    
       xmin2  =  xmin - xd2                                              
       nump1 = num + 1                                                     
       rel  =  xmax + xmin                                                 
       rel  =  abs ( rel )  *  0.5  / ( xmax - xmin )                             
c      :                                                              
       if( myid .eq. 0) then 
          write(6,*) Ctlab , 'vs.  ' , Cxlab 
       end if                                               
       if( rel .le. 50.0) then                                         
          xbase  =  xmin                                                 
       else                                                            
          xbase  =  0.0                                                  
          write(6 , 2600) xmin                                           
 2600     format(51x , '( + ' , e13.6 , ' )')                                
       end if                                                          
c      :                                                              
       do 40  i = 1 , nump1 
          axis ( i )  =  xbase + xd10 * ( i - 1)                                   
          if( abs ( axis ( i )) .lt. xd10 * 0.0001) axis ( i ) = 0.0 
   40  continue                                                        
c      :                                                              
       lform (6) = lformb ( lp )                                             
       write( 6 , lform )   ( axis ( i ) , i = 1 , nump1)                          
c      :                                                              
       do 50  j = 1 , lpmax                                                
          if( mod ( j , lp ) .eq. 1 ) then                                     
             l0 ( j )  =  li                                                   
          else                                                            
             l0 ( j )  =  lb                                                   
          end if                                                          
   50  continue                                                        
c      :                                                              
       mod0 = mod ( n - 1 , iskip )
       mod1 = 0
       do 100  i = 1 , n 
          if( mod ( i - 1 , iskip ) .ne. mod0 ) goto 100
c         ----------------------------------------------
          mod1 = mod1 + 1
          do 60  j = 1 , lpmax 
             l ( j )  =  l0 ( j ) 
 60       continue 
          xi  =  X ( i ) / Xnorm  
          if( i - iskip .ge. 1) xim1  =  X ( i - iskip ) / Xnorm  
          if( i + iskip .le. n ) xip1  =  X ( i + iskip ) / Xnorm 
          item  =  ( xi - xmin2) / xd + 1                                     
          item0  =  item                                                 
          item1  =  item                                                 
          if( mod1 .gt. 1) item0  =  ( xim1 - xmin2) / xd + 1                 
          if( i .lt. n ) item1  =  ( xip1 - xmin2) / xd + 1                   
          if( item .ge. 1 .and. item .le. lpmax ) then                  
            if( item0 .lt. item )   item0  =  item - 
     *      ( item - item0 - 1) / 2   
            if( item0 .gt. item )   item0  =  item + 
     *      ( item0 - item - 1) / 2   
            if( item1 .lt. item )   item1  =  item - 
     *      ( item - item1 - 1) / 2   
            if( item1 .gt. item )   item1  =  item + 
     *      ( item1 - item - 1) / 2   
            if( item1 .gt. lpmax ) item1  =  item                         
            if( item1 .lt. 1) item1  =  item                             
            if( item0 .gt. lpmax ) item0  =  item                         
            if( item0 .lt. 1) item0  =  item                             
            jtem0  =  item0                                             
            if( jtem0 .gt. item ) jtem0 = item                            
            if( jtem0 .gt. item1) jtem0 = item1                          
            jtem1  =  item0                                             
            if( jtem1 .lt. item ) jtem1 = item                            
            if( jtem1 .lt. item1) jtem1  =  item1                        
            do 80 j = jtem0 , jtem1                                       
               l ( j )  =  lx 
 80         continue 
            l ( item )  =  la                                              
          end if                                                       
          write(6 , 1602) ( i - 1) * Tunit + T0 ,
     *    ( l ( j ) , j = 1 , lpmax ) 
 1602     format(2x  , F7.2 , 1x , 101a1)                                   
  100  continue                                                        
       goto 9100                                                          
      end 

checkpoint:                  lano =    64/129/sp2.@990422.@152623 ........
contents    9.2   gfile               
c reusable
       subroutine gfile (
     i Figtype , Figtitle , Ylabel , Unit , Xmin , Xdiff , 
     i Ydata , Ymin , Ymax , Ymissing , Length , Nchannel ,
     i Nblock , Ib )
       implicit real * 8  ( a-h , o-z )  
#include "ardock.env"
       character*(*) Figtype , Figtitle , Ylabel , Unit                       
       real * 8  Ydata ( Length , Nchannel ) 
       dimension Ib ( Nblock )    
       character*80  form   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data  form / '(4d20.10)' / 
c      ..........................................................
c      gfile 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9       
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gfile', io , stio )
          call showm2 ('I',
     i    ' Writes graphics data summarized in Table 11',
     i    ' in Section 5.4.3 to a file.') 
          call showc ('I','Figtype' ,  Figtype ,   1 , 1 , 1)
          call showc ('I','Figtitle' , Figtitle ,  1 , 1 , 1)
          call showc ('I','Ylabel' ,   Ylabel ,    1 , 1 , 1)
          call showc ('I','Unit' ,     Unit ,      1 , 1 , 1)
          call showr ('I','Xmin' ,     Xmin ,      1 , 1 , 1)
          call showr ('I','Xdiff' ,    Xdiff ,     1 , 1 , 1)
          call showr ('I','Ydata' ,    Ydata ,     Length , Length ,
     *    Nchannel )
          call showr ('I','Ymin' ,     Ymin ,      1 , 1 , 1)
          call showr ('I','Ymax' ,     Ymax ,      1 , 1 , 1)
          call showr ('I','Ymissing' , Ymissing ,  1 , 1 , 1)
          call showi ('I','Length' ,   Length ,    1 , 1 , 1)
          call showi ('I','Nchannel' , Nchannel ,  1 , 1 , 1)
          call showi ('I','Nblock' ,   Nblock ,    1 , 1 , 1)
          call showi ('I','Ib' ,       Ib ,        1 , 1 , Nblock )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( mYID .ne. 0) goto 9100
       write(IOUNIT ,  * ) 'gfile'
       write(IOUNIT ,  * ) 'figtype = ' , Figtype 
       write(IOUNIT ,  * ) 'figtitle = ' , Figtitle 
       write(IOUNIT ,  * ) 'length = ' , Length 
       write(IOUNIT ,  * ) 'channel = ' , Nchannel 
       write(IOUNIT ,  * ) 'unit = ' , Unit 
       write(IOUNIT ,  * ) 'xmin = ' , Xmin 
       write(IOUNIT ,  * ) 'xdiff = ' , Xdiff 
       write(IOUNIT ,  * ) 'ylabel = ' , Ylabel 
       write(IOUNIT ,  * ) 'ymin = ' , Ymin 
       write(IOUNIT ,  * ) 'ymax = ' , Ymax 
       write(IOUNIT ,  * ) 'ymissing = ' , Ymissing 
       write(IOUNIT ,  * ) 'end'
       write(IOUNIT ,  * ) ( Ib ( i ) , i = 1 , Nblock )
       write(IOUNIT , '( a )') form 
       do 100  i = 1 , Length 
          write(IOUNIT , form ) ( Ydata ( i , j ) , j = 1 , Nchannel )
  100  continue 
       goto 9100 
      end 

checkpoint:                 lano =    65/129/sp2.@990422.@152623 ........
contents  10. hushld               subpackage
contents    10.1  hushld              
c reusable
      subroutine hushld (
     i Mhh , N , K , 
     a Hh )                     
       implicit real*8 ( a-h , o-z )                           
#include "ardock.env"
       dimension Hh ( Mhh , 1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init  / 1 /, eps /0.d0/
c      ........................................................
c      hushld        
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine transforms matrix to an upper triangular 
c      form by householder transformation.              
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('hushld', io , stio )
          call showm2 ('I',
     i    ' Executes Householder transformation(A.89)',
     i    ' of a real matrix.')
          call showi ('I','Mhh' , Mhh ,   1 , 1 , 1)    
          call showi ('I','N' ,   N ,     1 , 1 , 1)
          call showi ('I','K' ,   K ,     1 , 1 , 1)
          call showr ('A','Hh' ,  Hh ,    Mhh , N , K )
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      householder transformation 
       if( init .eq. 1) then 
          init  =  0 
          do 1 i = 10 , 100 
              epsx  =  10.d0 ** ( - i )
              one  =  1.d0 + epsx 
              if( one .lt. 0.d0) write(6,*) 'one'
              if( one .le. 1.d0) goto 2 
c             ------------------------
              eps  =  epsx 
c        --------------- 
    1    continue 
    2    eps =  eps ** 2 
       end if 
       mnk = K 
       if( n.lt.k ) mnk = N 
       do 100 ii = 1 , mnk 
          h = 0.0d0 
          h0  =  0.d0 
          do 10 i = 1 , N  
             h0 = h0 + Hh ( i , ii ) ** 2 
             if( i .ge. ii ) h = h + Hh ( i , ii ) ** 2 
   10     continue 
          if( h .le. eps * h0) then 
             g = 0.0d0 
             goto 99 
c             ======= 
          end if 
          g = dsqrt ( h )     
          if( ii.eq.k ) goto 99 
c         ------------------- 
          f = Hh ( ii , ii )     
          if( f.ge.0.0d0) g =  - g  
          dii = f - g 
          h = h - f * g 
          do 60 j = ii + 1 , K 
             s = dii * Hh ( ii , j )
             do 40 i = ii + 1 , N  
                s = s + Hh ( i , ii ) * Hh ( i , j ) 
   40        continue 
             s = s / h 
             Hh ( ii , j ) = Hh ( ii , j ) - dii * s 
             do 50 i = ii + 1 , N  
                Hh ( i , j ) = Hh ( i , j ) - Hh ( i , ii ) * s 
   50        continue 
   60     continue 
   99     continue 
          do 30 i = ii + 1 , N 
             Hh ( i , ii ) =  0.d0 
   30     continue 
          Hh ( ii , ii ) = g     
  100  continue 
       goto 9100 
      end   

checkpoint:                lano =    66/129/sp2.@990422.@152623 ........
contents    10.2  solve               
c reusable
      subroutine solve (
     i Mhh , Ip , K , Icnt , 
     a Hh , 
     o Ierr )
       implicit real  *  8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Hh ( Mhh , Mhh * 2) 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      solve 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine produces regression coefficients from the triangular 
c      matrix Hh prepared by hushld subroutine.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('solve', io , stio )                  
          call showm2 ('I',
     i    ' Solves Householder transformed linear equation(A.90).',
     i    ' See p.32 of CSM.')
          call showi ('I','Mhh' ,  Mhh ,    1 , 1 , 1)
          call showi ('I','Ip' ,   Ip ,     1 , 1 , 1)
          call showi ('I','K' ,    K ,      1 , 1 , 1)    
          call showi ('I','Icnt' , Icnt ,   1 , 1 , 1)
          call showr ('A','Hh' ,   Hh ,     Mhh , Ip , K )     
          call showi ('O','Ierr',  Ierr ,   1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Ierr = 0 
corrected2000.11.21 'if then' line is added by M.I.
       if( Icnt .ge. 0 ) then 
       do 2 k1 = K , Ip  + 1 , -1  
          do 22 j1 = k1 , Ip + 1 , -1
             sqe = 0.d0 
             do 1 j = Ip  + 1 , j1 
                sqe  =  sqe + Hh ( j , k1 ) * Hh ( j , j1 ) 
    1        continue 
             Hh ( j1 , k1 )  =  sqe 
             Hh ( k1 , j1 )  =  sqe 
   22     continue 
    2  continue 
corrected2000.11.21 'end if' is added by M.I.
       end if
       if( Ip .le. 0 .or. Icnt .eq. 0) goto 9100 
c      ----------------------------------------
       do 100 k1 = Ip  + 1 , K 
       do  10  i = Ip , 1 ,  - 1 
          if( Hh ( i , i ) .ne. 0.d0) then 
             Hh ( i , k1) = Hh ( i , k1) / Hh ( i , i )
          else 
             if( Hh ( i , k1) .eq. 0.d0) then 
                if( Ierr .eq. 0) Ierr = 1 
             else 
                if( Ierr .le. 1) Ierr = 2 
             end if 
             Hh ( i , k1) = 0.d0 
          end if 
          if( i .gt. 1 ) then 
             do  20   j  =  1 , i - 1 
                Hh ( j , k1) =  
     *          Hh ( j , k1) - Hh ( j , i ) * Hh ( i , k1)
   20        continue 
          end if 
   10  continue  
  100  continue 
       goto 9100 
      end 

checkpoint:               lano =    67/129/sp2.@990422.@152623 ........
contents    10.3  cxhushld            
c reusable
       subroutine cxhushld (
     i Mhh , N , K , 
     a Hh )                     
       implicit real*8 ( a-h , o-z )                           
#include "ardock.env"
       dimension Hh (2 , Mhh , Mhh * 2) ,  g (2)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init  / 1 /, eps /0.d0/
c      .........................................................
c      cxhushld 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine transforms complex matrix to an upper triangular 
c      form by Householder transformation.              
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('cxhushld', io , stio )
          call showm ('I',
     i    ' Complex number version of hushld.')
          call showi ('I','Mhh' , Mhh ,   1 , 1 , 1)    
          call showi ('I','N' ,   N ,     1 , 1 , 1)
          call showi ('I','K' ,   K ,     1 , 1 , 1)
          call showr ('A','Hh',   Hh ,    2 * Mhh , N * 2 , K )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      complex Householder transform 
       if( init .eq. 1) then 
          init  =  0 
          do 1 i = 10 , 100 
              epsx  =  10.d0 ** ( - i )
              one  =  1.d0 + epsx 
              if( one .lt. 0.d0) write(6,*) 'one'
              if( one .le. 1.d0) goto 2 
c             ------------------------
              eps  =  epsx 
c        --------------- 
    1    continue 
    2    eps =  eps ** 2 
       end if 
       mnk = K 
       if( n.lt. K ) mnk = N 
       do 100 ii = 1 , mnk 
          h = 0.0d0 
          h0 = 0.d0 
          do 10 i = 1 , N  
             hi = Hh (1 , i , ii ) ** 2 + Hh (2 , i , ii ) ** 2 
             h0 = h0 + hi 
             if( i .eq. ii ) hii = hi 
             if( i .ge. ii ) h = h + hi 
   10     continue     
          if( h.le.eps * h0) then 
             g (1) = 0.0d0 
             g (2) = 0.0d0 
             goto 99 
c             ======= 
          end if 
c         ------
          if( hii .le. eps * h0) then 
             g (1) = dsqrt ( h )
             g (2) = 0.d0 
          else 
             sqrth  =  dsqrt ( h )
             hii  =  dsqrt ( hii )
             g (1) =  - sqrth * Hh (1 , ii , ii ) / hii 
             g (2) =  - sqrth * Hh (2 , ii , ii ) / hii 
          end if 
          if( ii.eq.k ) goto 99 
c         ------------------- 
          d1 = Hh (1 , ii , ii ) - g (1)
          d2 = Hh (2 , ii , ii ) - g (2)
          h = h - Hh (1 , ii , ii ) * g (1) - 
     *    Hh (2 , ii , ii ) * g (2)
          do 60 j = ii + 1 , K 
c            d* = d(1)-i*d(2) vs. x(1)+i*x(2)
c            d*x = d(1)x(1) - (-d(2)x(2)) + i*(d(1)x(2) - d(2)x(1))
             s1 = d1 * Hh (1 , ii , j ) + d2 * Hh (2 , ii , j )
             s2 = d1 * Hh (2 , ii , j ) - d2 * Hh (1 , ii , j )
             do 40 i = ii + 1 , N  
                s1 = s1 + Hh (1 , i , ii ) * Hh (1 , i , j ) + 
     *          Hh (2 , i , ii ) * Hh (2 , i , j )
                s2 = s2 + Hh (1 , i , ii ) * Hh (2 , i , j ) - 
     *          Hh (2 , i , ii ) * Hh (1 , i , j )
   40        continue                   
             s1 = s1 / h 
             s2 = s2 / h 
c            s*d  =  s(1)d(1) - s(2)d(2) + i*( s(1)d(2) + s(2)d(1))
             Hh (1 , ii , j ) = Hh (1 , ii , j ) - s1 * d1 + s2 * d2 
             Hh (2 , ii , j ) = Hh (2 , ii , j ) - s1 * d2 - s2 * d1 
             do 50 i = ii + 1 , N  
                Hh (1 , i , j ) = Hh (1 , i , j ) - 
     *          s1 * Hh (1 , i , ii ) + s2 * Hh (2 , i , ii )
                Hh (2 , i , j ) = Hh (2 , i , j ) - 
     *          s1 * Hh (2 , i , ii ) - s2 * Hh (1 , i , ii ) 
   50        continue                      
   60     continue 
   99     continue 
          do 30 i = ii + 1 , N 
             Hh (1 , i , ii ) =  0.d0 
             Hh (2 , i , ii ) =  0.d0 
   30     continue 
          Hh (1 , ii , ii ) = g (1)
          Hh (2 , ii , ii ) = g (2)
  100  continue     
       goto 9100 
      end   

checkpoint:              lano =    68/129/sp2.@990422.@152623 ........
contents    10.4  cxsolve             
c reusable
      subroutine cxsolve (
     i Mhh , Ip , K , Icnt , 
     a Hh , 
     o Ierr )
       implicit real  *  8 ( a-h , o-z ) 
#include "ardock.env"
       dimension Hh (2 , Mhh , Mhh * 2) 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      cxsolve 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine produces regression coefficients from the triangular 
c      complex matrix Hh prepared by cxhushld subroutine.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('cxsolve', io , stio )                  
          call showm ('I',
     i    ' Complex number version of solve.')
          call showi ('I','Mhh' ,  Mhh ,   1 , 1 , 1)
          call showi ('I','Ip' ,   Ip ,    1 , 1 , 1)
          call showi ('I','K' ,    K ,     1 , 1 , 1)    
          call showi ('I','Icnt' , Icnt ,  1 , 1 , 1)
          call showr ('A','Hh' ,   Hh ,    2 * Mhh , 2 *  Ip , K )     
          call showi ('O','Ierr' , Ierr ,  1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Ierr = 0 
corrected2000.11.21 'if then' line is added by M.I.
       if( Icnt .ge. 0 ) then 
       do 2 k1 = K , Ip + 1 , -1
          do 22 j1 = k1 , Ip + 1 , -1 
             sqr = 0.d0 
             sqi = 0.d0
             do 1 j = Ip + 1 , j1 
c               sqr + sqi*i = 
c               sqr + sqi*i 
c               + {Hh(1,j,k1) - i*Hh(2,j,k1)}
c               * {Hh(1,j,j1) + i*Hh(2,j,j1)}
c               = sqr + sqi*i 
c               +    Hh(1,j,k1)*Hh(1,j,j1) + Hh(2,j,k1)*Hh(2,j,j1)
c               + i*{Hh(1,j,k1)*Hh(2,j,j1) - Hh(2,j,k1)*Hh(1,j,j1)
                sqr  =  sqr + Hh ( 1 , j , k1 )* Hh ( 1 , j , j1 ) +
     *                        Hh ( 2 , j , k1 )* Hh ( 2 , j , j1 )  
                sqi  =  sqi + Hh ( 1 , j , k1 )* Hh ( 2 , j , j1 ) -
     *                        Hh ( 2 , j , k1 )* Hh ( 1 , j , j1 )  
    1        continue 
             Hh (1 , j1 , k1)  =  sqr 
             Hh (2 , j1 , k1)  =  sqi 
             Hh (1 , k1 , j1)  =  sqr 
             Hh (2 , k1 , j1)  =  - sqi 
   22     continue 
    2  continue 
corrected2000.11.21 'end if' is added by M.I.
       end if 
       if( Ip .le. 0 .or. Icnt .eq. 0) goto 9100 
c      ----------------------------------------
       do 100 k1 = Ip  + 1 , K 
       do  10  i = Ip , 1 ,  - 1 
c         (a1 + i* 2)/(b1 + i*b2)  =  (a1 + i*a2)*(b1 - i*b2)/(b1**2 + b2**2)
c          =  {(a1*b1 + a2*b2) + i * (a2*b1 - a1*b2)} / (b1** 2 + b2**2)
          den  =  Hh (1 , i , i ) ** 2 + Hh (2 , i , i ) ** 2 
          x1  =  Hh (1 , i , k1) * Hh (1 , i , i ) + 
     *    Hh (2 , i , k1) * Hh (2 , i , i )
          x2  =  Hh (2 , i , k1) * Hh (1 , i , i ) - 
     *    Hh (1 , i , k1) * Hh (2 , i , i )
          if( den .ne. 0.d0) then 
             Hh (1 , i , k1)  =  x1 / den 
             Hh (2 , i , k1)  =  x2 / den 
          else 
             if( x1 .eq. 0.d0 .and. x2 .eq. 0.d0) then 
                if( Ierr .eq. 0) Ierr = 1 
             else 
                if( Ierr .le. 1) Ierr = 2 
             end if 
             Hh (1 , i , k1)  =  0.d0 
             Hh (2 , i , k1)  =  0.d0 
          end if 
          if( i .gt. 1 ) then 
             do  20   j  =  1 , i - 1 
                Hh (1 , j , k1) =  Hh (1 , j , k1) - 
     *          Hh (1 , j , i ) * Hh (1 , i , k1) + 
     *          Hh (2 , j , i ) * Hh (2 , i , k1)
                Hh (2 , j , k1) =  Hh (2 , j , k1) - 
     *          Hh (1 , j , i ) * Hh (2 , i , k1) - 
     *          Hh (2 , j , i ) * Hh (1 , i , k1)
   20        continue  
          end if 
   10  continue  
  100  continue 
       goto 9100 
      end 

checkpoint:             lano =    69/129/sp2.@990422.@152623 ........
contents    10.5  fouger              
c reusable
      subroutine fouger (
     i Rangl , Rangh , G , Lgp1 , Lfp1 , 
     o Fc , Fs )
       implicit real * 8 ( a-h , o-z )  
#include "ardock.env"
       dimension G ( lgp1) , Fc ( lfp1) , Fs ( lfp1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ..........................................................
c      fouger 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine computes Fourier transform of G(i), i=0,1,...,lg at 
c      frequencies between Rangl and Rangh and returns cosin transform in 
c      Fc ( k ) and sin transform in Fs ( k ). Goertzel method is used. 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('fouger', io , stio )
          call showm2 ('I',
     i    ' Executes  Fourier transformation by Goertzel method.',
     i    ' Calls fouge1.')
          call showr ('I','Rangl', Rangl ,    1 , 1 , 1)
          call showr ('I','Rangh', Rangh ,    1 , 1 , 1)
          call showr ('I','G' ,    G ,        1 , 1 , lgp1)
          call showi ('I','Lgp1',  Lgp1 ,     1 , 1 , 1)    
          call showi ('I','Lfp1',  Lfp1 ,     1 , 1 , 1)    
          call showr ('O','Fc' ,   Fc ,       1 , 1 , lfp1)
          call showr ('O','Fs' ,   Fs ,       1 , 1 , lfp1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      reversal of G ( i ) , i = 1 , ... , Lgp1 into G ( Lgp1 + 1 - i )
       lf = Lfp1 - 1              
       af0 = ( Rangh - Rangl ) / lf 
       do 10 k = 1 , Lfp1 
       af = af0 * ( k - 1) + Rangl 
       call fouge1 (
     i G , af , Lgp1 , 
     o Fc ( k ) , Fs ( k ))
   10  continue 
       goto 9100 
      end   

checkpoint:            lano =    70/129/sp2.@990422.@152623 ........
contents    10.6  fouge1             
c reusable
      subroutine fouge1 (
     i G , Af , Lgp1 , 
     o Fc , Fs )
       implicit real * 8 ( a-h , o-z )  
#include "ardock.env"
       dimension G ( lgp1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init  / 1 /, pi2 /0.d0/
c      ........................................................
c      fouge1        
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine computes Fourier transform of G(i),i=0,1,...,lg at 
c      frequency Af and returns cosin transform in Fc and sin transform 
c      in fs.  
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('fouge1', io , stio )
          call showm2 ('I',
     i    ' Executes  Fourier transformation by Goertzel method.',
     i    ' See p.32 of CSM.')
          call showr ('I','G' ,    G ,       1 , 1 , lgp1)
          call showr ('I','Af' ,   Af ,      1 , 1 , 1)    
          call showi ('I','Lgp1' , Lgp1 ,    1 , 1 , 1)    
          call showr ('O','Fc' ,   Fc ,      1 , 1 , 1)
          call showr ('O','Fs' ,   Fs ,      1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      Goertzel method 
       if( init .eq. 1) then 
          init = 0 
          pi2  =  2.d0 * atan2 (0.d0 ,  - 1.d0) 
       end if 
       lg = Lgp1 - 1 
       t = pi2 * Af 
       c = cos ( t ) 
       s = sin ( t )
       c2 = 2.d0 * c 
       um2 = 0.d0 
       um1 = 0.d0 
       if( lg.gt.0) then 
          do 11 i = Lgp1 , 2 ,  - 1 
             um0 = c2 * um1 - um2 + G ( i )
             um2 = um1  
             um1 = um0 
   11     continue 
       end if 
       Fc = c * um1 - um2 + G (1) 
       Fs = s * um1 
       goto 9100 
      end   

checkpoint:           lano =    71/129/sp2.@990422.@152623 ........
contents    10.7  posmat              
c reusable
      subroutine posmat (
     i Cmd , Ldim , Lmax , 
     a Sqrvar , 
     o Det , Ierr )
       implicit real * 8 ( a-h , o-z )   
#include "ardock.env"
       character*(*) Cmd 
       dimension Sqrvar ( Lmax , Lmax )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ............................................................
c      posmat 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('posmat', io , stio )
          call showm3 ('I',
     i    ' Executes Cholesky decomposition(3.31). See p.32 of CSM.',
     i    ' The inverse computation, eg. the construction',
     i    ' of $\Sigma = L^T L$, can be done by this routine.')
          call showc ('I','Cmd' ,   Cmd ,      1 , 1 , 1)
          call showi ('I','Ldim' ,  Ldim ,     1 , 1 , 1)
          call showi ('I','Lmax' ,  Lmax ,     1 , 1 , 1)
          call showr ('A','Sqrvar', Sqrvar ,   Lmax , Ldim , Ldim )    
          call showr ('O','Det' ,   Det ,      1 , 1 , 1)
          call showi ('O','Ierr' ,  Ierr ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Ierr  =  0 
       if( Cmd .eq. 'root') then 
          Det  =  1.d0 
          do 4 j = 1 , Ldim 
             pivot  =  Sqrvar ( j , j )
             if( pivot .gt. 0.d0) then 
                Det  =  Det * pivot 
                Sqrvar ( j , j ) = dsqrt ( pivot )
                do 5 k = 1 , Ldim 
                   if( k .ne. j ) Sqrvar ( k , j ) = 
     *             Sqrvar ( k , j ) / Sqrvar ( j , j )
    5           continue 
                if( j .lt. Ldim ) then 
                   do 6 l = j + 1 , Ldim 
                      ril  =   - Sqrvar ( j , l ) / Sqrvar ( j , j )
                      Sqrvar ( j , l ) =  - Sqrvar ( j , l ) / pivot 
                      do 66 k = 1 , Ldim 
                         if( k .ne. j ) then 
                            Sqrvar ( k , l ) =  Sqrvar ( k , l )  + 
     *                      ril  *  Sqrvar ( k , j )
                         end if 
   66                 continue 
    6              continue 
                end if 
             else 
                Ierr = 1  
                do 55 k = 1 , Ldim 
                   Sqrvar ( k , j ) = 0.d0 
                   if( k .gt. j ) Sqrvar ( j , k ) = 0.d0 
   55           continue 
             end if 
    4     continue  
       else 
          do 100 j = Ldim , 1 ,  - 1 
          do 90 i = j , 1 ,  - 1 
             sum = 0.d0 
             do 80 k = 1 , i 
                sum  =  sum + Sqrvar ( j , k ) * Sqrvar ( i , k )
   80        continue 
             Sqrvar ( i , j ) = sum 
             Sqrvar ( j , i ) = sum 
   90     continue 
  100     continue 
       end if 
       goto 9100 
      end   

checkpoint:          lano =    72/129/sp2.@990422.@152623 ........
contents    10.8  invmat              
c reusable
      subroutine invmat (
     i Ldim , Lmax , 
     a Sqrvar , 
     o Det , Ierr )
       implicit real * 8 ( a-h , o-z )   
#include "ardock.env"
       dimension Sqrvar ( Lmax , Lmax )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ..........................................................
c      invmat       
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('invmat', io , stio )
          call showm2 ('I',
     i    ' Executes inversion and determinant computation',
     i    ' of a positive definite matrix')
          call showi ('I','Ldim' ,  Ldim ,     1 , 1 , 1)
          call showi ('I','Lmax' ,  Lmax ,     1 , 1 , 1)
          call showr ('A','Sqrvar' ,Sqrvar ,   Lmax , Ldim , Ldim )    
          call showr ('O','Det' ,    Det ,      1 , 1 , 1)
          call showi ('O','Ierr' ,   Ierr ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       call posmat (
     i 'root' , Ldim , Lmax , 
     a Sqrvar , 
     o Det , Ierr )
       do 300 k = Ldim , 1 ,  - 1 
       do 302 j = 1 , k 
          if( j .lt. k ) then 
              sum  =  Sqrvar ( j , k ) / Sqrvar ( k , k )
          else 
              sum  =  1.d0 / Sqrvar ( k , k ) ** 2     
          end if 
          if( k .lt. Ldim ) then 
              do 301 l = k + 1 , Ldim 
                 sum  =  sum + Sqrvar ( j , l ) * Sqrvar ( k , l )
  301         continue 
          end if 
          Sqrvar ( k , j )  =  sum 
  302  continue 
  300  continue 
       do 200 j = 2 , Ldim 
       do 202 k = 1 , j - 1 
          Sqrvar ( k , j ) = Sqrvar ( j , k )
  202  continue 
  200  continue 
       goto 9100 
      end 

checkpoint:         lano =    73/129/sp2.@990422.@152623 ........
contents    10.9  rn01                
creusable
      function rn01 (
     i Ix )
       implicit real * 8 (a-h ,o-z)
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data rmd  / 2147483647.d0 /  ,  const  / 65540.d0 / 
       data mxseed /12345/
c      ........................................................
c      rn01 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('rn01', io , stio )
          call showm3 ('I',
     i    ' Generates uniform random number.',
     i    '  Feed Ix > 0 for the initialization.',
     i    '  Feed Ix = 0 to get random number.')
          call showi ('I','Ix' , Ix , 1 , 1 , 1)
          call showr ('O','Rn01' , Rn01 , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Ix .ne. 0) then 
          mxseed  =  Ix 
          Rn01 = Ix 
          goto 9100 
c         ========= 
       end if 
c      ------
    1  continue     
       if( mxseed .gt. 0) then 
          w  =  mxseed 
          w  =  const * w 
          if( w .ge. rmd ) then 
             iover  =  w / rmd 
             w  =  w - float ( iover ) * rmd 
          end if 
          mxseed  =  w 
          Rn01  =  w / rmd 
       else 
          if( mxseed .eq. 0) mxseed  =  1496 
          if( mxseed .gt. 0) goto 1 
          mxseed  =  - mxseed 
         goto 1 
       end if 
       goto 9100 
      end 

checkpoint:        lano =    74/129/sp2.@990422.@152623 ........
contents    10.10 rnor                
c reusable
      function rnor (
     i Std )                     
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
corrected1999.12.14 following 1 line is added by M.I.
       save pi2 , rnext 
       data isw  / 0 /  ,  init  / 1 / 
c      ........................................................
c      rnor 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('rnor', io , stio )
          call showm ('I',
     i    ' Generates normal random number by Box-Muller method.')
          call showr ('I','Std' , Std , 1 , 1 , 1)
          call showr ('O','Rnor' , Rnor , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          pi2  =  2.d0 * atan2 (0.d0 ,  - 1.d0) 
       end if 
       isw  =  1 - isw 
       if( isw .gt. 0) then 
    1     u  =  rn01 (0)
          if( u .le. 0.d0) goto 1 
          r  =  sqrt ( - 2.d0 * log ( u ))
          t  =  pi2 * rn01 (0)
          Rnor  =  r * cos ( t )
          rnext =  r * sin ( t )
       else 
          Rnor  =  rnext 
       end if 
       Rnor  =  Rnor * Std 
       goto 9100 
      end 

checkpoint:       lano =    75/129/sp2.@990422.@152623 ........
contents  11. dall                 subpackage
contents    11.1  dall                
c reusable
      subroutine dall (
     * Model , A , Ip , El , G , Vd , Endc , Step , Limit , Lpsw )
       implicit real*8 ( a-h , o-z )                                      
#ifdef MODIFIER
#include "ardock.env"
#endif
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif
       parameter ( nprof = 11)                                            
       common  /cdall/ NCOUNT , limitx , lpswmpi 
       dimension El (1) , A ( Ip )                                        
       dimension G ( Ip ) ,  Vd ( Ip , Ip  + 5)             
       dimension y ( nprof ) , Step ( Ip )                                   
       external Model 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
c      1998.5 M.I.
       common /dwhymper/  iwrhist 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      .............................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c         several minor changes. The most crucial one is handling 
c         of Model output lel. Now ,  it should be:
c           lel > 0 if Model is successfully evaluated , 
c               =  0 if Model can not be evaluated.          
c      version - 0     1998.12 
c   history             - 1989.7   original version 
c                       - 1996.11  MPI version 
c                       - 1997.7   minor clean - up ( lpswmpi etc.)
c                       - 1997.8   WHYMPER option 
c                       - 1998.5   mask option 
c                       - 1998.6   MPION / OFF control 
c                       - 1998.10  lel sence reversed 
c 
c      DALL: Davidon's Algorithm for Log Likelihood Maximization             '
c      --- A FORTRAN subroutine for statistical model builders -- 
c      Version F_MPI_2 ( for MPI - parallel computer ) 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      Model        - input. subroutine name.                          
c      A ( ip )       - input. parameter.                                
c      Ip          - input. number of free parameter.                 
c      El          - output. maximum log likelihood.                  
c      G ( ip )       - output. final gradient     
c      Vd ( ip , ip  + 5) - output / work area. 
c                      first ip columns: inverse Hessian matrix estimation 
c      Endc        - output. end code.                                
c                    endc =  numerical differentiation routine call count 
c                          + lcode / 100 
c 
c                   lcode     message 
c                       0  D1:Successfully finished 
c                             Bill ended with abs (RHO) < rhomin. 
c                      50  D1:NCOUNT exeeded given limit.
c                             Bill stopped midway.
c                      70  D1:Bill reached dead end with 
c                                     abs ( log LAMBDA) < ramlim.
c                      71  D1:Bill reached dead end with 
c                                      ISPHI   =  isplim.    
c                      72  D1:Bill reached dead end with 
c                                     initial search failure.
c                      85  D1:Bad initial guess!
c                             function can't be evaluated.                    '
c                      90  D0:Setting of lel variable is incorrect. 
c                             Set lel = 1 when function can be evaluated , 
c                             set lel = 0 if not.
c                      95  D0:step vector has zero element. 
c                         (The number after D represents the output level.)
c 
c      Step ( ip )    - input. step size for the numerical 
c                           differentiation. 
c      Limit       - input. numerical differentiation routine call limit 
c                           Set limit  =  0 for no - limit option.
c      Lpsw        - input. output level control.  0 = < lpsw < = 3. 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('dall', io , stio )
          call showm2 ('I',
     i    ' Numerically optimizes log likelihood.',
     i    ' See p.33 and Appendix D of CSM.')
          call showr ('A','A' ,     A      , 1 , 1 , Ip )
          call showi ('I','Ip' ,    Ip     , 1 , 1 , 1)
          call showr ('I','Step' ,  Step   , 1 , 1 , Ip )
          call showi ('I','Limit' , Limit  , 1 , 1 , 1)
          call showi ('I','Lpsw' ,  Lpsw   , 1 , 1 , 1)
          call showr ('O','El' ,   El     , 1 , 1 , 1)
          call showr ('O','G' ,    G      , 1 , 1 , Ip )
          call showr ('O','Vd' ,   Vd     , Ip , Ip , Ip )
          call showr ('O','Endc' , Endc   , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       El (1) = val 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      1997.8 M.I. 
#ifdef AUTHOR
       if( mAINT .eq. 1 ) then 
          if( Endc .eq. 1496.d0) then 
            iwrhist  =  1 
          else 
            iwrhist  =  0 
          end if
       end if 
#endif
       lpswmpi  =  Lpsw 
       nprocs  =  1 
       limitx  =  Limit 
#ifdef MPI 
       call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
       call mpi_comm_size (MPI_COMM_WORLD , nprocs , IERR)
       if( myid .ne. 0) lpswmpi  =  0 
#endif 
c                                                                     
c      function check 
       lel =  - 1496 
#ifdef AUTHOR  
       if( mAINT .eq. 1 ) then 
c         - 1998.5   mask option 
          call set (1 , Vd (1 , Ip  + 5) , ipq , A , Ip )
          call Model ( Vd (1 , Ip  + 5) , ipq , El , lel )
       else
          call Model ( A , Ip , El , lel )
       end if
#else
       call Model ( A , Ip , El , lel )
#endif
       val = El (1)                         
       if( lel .le. 0) then                                              
         if( lel .eq.  - 1496) then                                     
c            ********                                                
            lcode = 90 
            if( myid .eq. 0) then 
               write(6,*) 'D0:Setting of lel variable is not correct.'    
               write(6,*) '   Set lel=1 when function can be evaluated.' 
            end if 
            goto 1496                                             
c           ------------------------------- >1496                   
         end if 
         if( lel .lt. 0) then                                           
c            ********                                                   
            lcode = 90 
            if( myid .eq. 0) then     
               write(6,*) 'D0:Setting of lel variable is not correct.'    
               write(6,*) 
     *               '   Set lel = 0 when function can''t be evaluated.' 
            end if 
            goto 1496                                                
c           ------------------------------- >1496                   
         end if                                                       
c         ********                                                      
         lcode  =  85 
         if( lpswmpi .gt. 0) then     
            write(6,*) 'D1:lel = 0  Bad initial guess!'                     
            write(6,*) '   function can''t be evaluated.' 
         end if  
         goto 1496                                                   
c        ------------------------------- >1496                         
       end if                                                          
c      :                                                              
c      :                                                              
c      initialization 
       do 1234 i = 1 , Ip                                                  
         if( Step ( i ) .eq. 0) then 
c            ********                                                      
            lcode  =  95 
            if( myid .eq. 0) then        
               write(6,*) 'D0:step vector has zero element.'    
            end if 
            goto 1496                                                   
c           ------------------------------- >1496                         
         end if 
       Vd ( i , Ip  + 1) = A ( i )
 1234  continue 
       NCOUNT = 0                    
       ireset = 0                                                        
       drop = 0.d0                                                       
c      :                                                              
       if( lpswmpi .gt.0) then 
         write(6 , 6149)                                    
         write(6,*) 'D1:number of processor  = ' , nprocs 
         if( Limit .eq. 0) then 
            write(6,*) 'D1:no Limit for NCOUNT'
         else 
            write(6,*) 'D1:NCOUNT Limit = ' , Limit 
         end if 
 6149    format( /  , 
     *   ' D1:==========  log likelihood maximization =========')
       end if 
c      :                                                              
c      :                                                              
c      + =============================== <4210                          
 4210  continue                                                        
c      innovation variance ,  gradient and hessian computation 
       call numdif ( Model , A , Ip , El , ihess , G , Vd , 2 , Step )
       val = El (1)
 4211  continue                                                        
c      :                                                              
       vinit = val                                                       
c      :                                                              
c      : ...............................                              
         if( lpswmpi .gt.1) then                                          
c           initial print out                                         
            write(6 , 3112) ireset                                      
 3112       format( /  , ' D2:Hessian reset count  = ' , i3)                  
            write(6 , 1008)  2 ,  vinit                                   
 1008       format(1x  , 'D' , i1 , ':value = ' , f15.2)                        
            write(6 , 1621) 2                                           
 1621       format(1x  , 'D' , i1 , ':point')                               
            write(6 , 6666) ( A ( i ) , i = 1 , Ip )                               
         end if                                                       
c      : ...............................                              
c      :                                                              
c      Inverse of Hessian computation.                                 
       do 1910 i = 1 , Ip              
         if( Vd ( i , i ) .lt. 0.d0) then                                   
            Vd ( i , i ) = 1.d0 / Vd ( i , i )                                 
         else                                                         
            if( G ( i ) .eq. 0.d0) then                                   
               Vd ( i , i ) =  - 1.d0                                          
            else                                                      
                Vd ( i , i ) =  - Step ( i ) / 
     *          dabs ( G ( i )) * 1.d2                     
            end if                                                    
         end if            
 1910  continue                                                        
c      :                                                              
c      :                                                              
c      Davidon's procedure                                                    '
       call bill ( Model , A , Ip , El , G , Vd , lcode , Step , 
     * Vd (1 , Ip  + 2) , Vd (1 , Ip  + 3) , Vd (1 , Ip  + 4) ,
     * Vd (1 , Ip  + 5))
       val = El (1) 
c      :                                                              
c      :                                                              
       vdif = val - vinit                                                  
       drop = drop + vdif                                                  
c      : ...............................    
         if( lpswmpi .gt. 1) then 
            write(6 , 1009) 2 , vdif                         
            write(6,'('' D2:NCOUNT = '',I6)') NCOUNT 
 1009       format(1x ,'D',i1,':val. dif. = ',f15.2)
         end if                       
c      : ...............................      
c      :                                                              
c      :                                                              
       if( lcode .eq. 0 .or. vdif .eq. 0.d0) then 
         if( lpswmpi .gt. 0) then 
            if( lcode .eq. 0) 
     *      write(6,*) 'D1:Bill ended with abs (RHO) < rhomin.'       
            if( lcode .eq. 70) 
     *      write(6,*) 'D1:Bill ended with abs ( log LAMBDA) < ramlim.'       
            if( lcode .eq. 71) 
     *      write(6,*) 'D1:Bill ended with  ISPHI  =  isplim.'       
            if( lcode .eq. 72) 
     *      write(6,*) 'D1:Bill ended with initial search failure.'       
         end if 
         goto 1498                                                   
c         ================================ > 1498                       
       end if 
c      :
c      :
       if( lcode .eq. 50) then 
         if( lpswmpi .gt. 0) 
     *   write(6,*) 'D1:NCOUNT exeeded given limit.'     
         goto 1498                                                   
c         ================================ > 1498                       
       end if 
c      :
c      :
       ireset = ireset + 1                                                 
       goto 4210                                                      
c      ================================== >4210                         
c      :                                                              
c      :                                                              
c      :                                                              
c      :                                                              
c      +  ==================================== <1498                    
 1498  continue 
c      :
c      :                                                         
       if( lpswmpi .gt. 0) then                                            
         if( lpswmpi .gt. 1 ) write(6,6150)                                
 6150    format(1x ,'D2: ==========   Summary  ========= ') 
         write(6,1008) 1 , val                                          
         write(6,1621) 1                                              
         write(6,6666) ( A ( i ) , i = 1 , Ip )                                
 6666    format(1x  , 5x , 5d13.5 / (1x  , 5x , 5d13.5)) 
         if( ihess .eq. 0 .and. lpswmpi .gt. 1) then                      
            write(6 , 1010)                                             
 1010       format(1x  , 'D2:final gradient')                           
            write(6 , 6666) ( G ( i ) , i = 1 , Ip )                               
         end if                                                       
         write(6 , 1009) 1 , drop                                         
       end if                                                          
c      :                                                              
c      --------------------------------- <1496                        
 1496  Endc = NCOUNT + lcode / 100.d0                                        
c      :                                                              
       stepx = 0.d0                                                  
       do 8762 i = 1 , Ip                                                
         stepx = stepx + ( A ( i ) - Vd ( i , Ip  + 1)) ** 2 
 8762  continue 
c      :                                                           
       if( stepx .ne. 0.d0) then 
         if( Lpsw .gt. 1) then                                    
            rlim = 0.d0                                                 
            call eval ( Model , El , Vd (1 , Ip  + 1) , A , Ip ,  
     i      nprof , 
     o      y , rlim , 
     w      Vd (1 , Ip  + 2) , Vd (1 , Ip  + 3) , Vd (1 , Ip  + 4))
            if( lpswmpi .ne. 0) then                                           
               write(6 , 654)                                              
  654          format(1x  , 'D2:global profile')                           
               call lgraph (
     i         y , nprof , rlim , 'log likelihood' , 1.d0 , 
     i         0.d0 , 0.d0 , 0.d0 , 1.d0 / ( nprof - 1) ,
     i         ' ' , nprof , 1)
            end if 
         end if 
       else                                                         
         if( lpswmpi .gt. 0) then                                            
            write(6 , 866)                                              
  866       format(1x  , 'D1:didn''t move')                             
         end if 
       end if                                                       
c      :
       if( lpswmpi .gt. 0) then 
         write(6 , 8654) ireset                                         
 8654    format(1x  , 'D1:Hessian reset count  = ' , i4)                    
         write(6 , 8655) Endc                                           
 8655    format(1x  , 'D1:end code  = ' , f7.2)                             
         write(6 , 867)                                                 
  867    format(1x ,'D1:============= end of maximization ===========')
       end if                                                          
c      :                                                              
       goto 9100 
      end                                                             

checkpoint:      lano =    76/129/sp2.@990422.@152623 ........
contents    11.2  bill                
c reusable
      subroutine bill (
     * Model , X , Ip , El , G , Vd , Lcode , Step , c , sx , sg , sr ) 
       implicit real*8 ( a-h , o-z )                                 
#ifdef MODIFIER
#include "ardock.env"
#endif
       common  /cdall/ NCOUNT , limitx , lpswmpi 
       parameter ( ramlim  =  0.2d0)                
       dimension El (1) , Vd ( Ip , Ip )                    
       dimension X ( Ip ) , G ( Ip ) , c ( Ip ) , sx ( Ip ) , 
     * sg ( Ip ) , sr ( Ip ) ,
     * Step ( Ip )               
       external Model                                                   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data cst1  / 1.0d - 00 /  ,  cst05  / 0.5d - 00 /  ,            
     * consta  / 0.25d - 00 /  ,  constb  / 4.0d - 00 /  , 
     * rhomin  / 0.0001d0 /  ,  isplim  / 5 /                    
c      ........................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c         several minor changes. The most crucial one is handling 
c         of Model output lel. Now ,  it should be:
c           lel > 0 if Model is successfully evaluated , 
c               = 0 if Model can not be evaluated.
c      version - 0     1998.12          
c      bill 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          El (1) = val 
       end if
#ifdef MODIFIER
       myself = 9    
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('bill', io , stio )
          call showm3 ('I',
     i    'Maximizes log likelihood function by',
     i    ' William C. Dadidon''s algorithm.',
     i    ' See Figure 2 of Appendix D of CSM.')
          call showr ('A','X' ,     X      , 1 , 1 , Ip )
          call showr ('I','Step' ,  Step   , 1 , 1 , Ip )
          call showi ('I','Ip' ,    Ip     , 1 , 1 , 1)
          call showr ('I','G' ,     G      , 1 , 1 , Ip )
          call showr ('I','Vd' ,    Vd     , Ip , Ip , Ip )
          call showr ('O','El' ,    El     , 1 , 1 , 1)
          call showi ('O','Lcode' , Lcode  , 1 , 1 , 1)
          call showw ('c',      Ip     , 1)
          call showw ('sx',     Ip     , 1)
          call showw ('sg',     Ip     , 1)
          call showw ('sr',     Ip     , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          val = El (1)
          goto 9200
       end if 
c      ------
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      :                                                              
c      constant     
       isplim = Ip   
c      :                                                              
c      initialization 
       ISPHI = 0   
corrected2000.10.20  1 line correction made by M.I.
c       isphix = 1 
       isphix = 0 
       itn = 0                                                           
       PHI = val                                                         
       if( lpswmpi .eq. 3) write(6,666)                                
  666  format(1x ,'B3: NCOUNT',10x,' PHI',5x,'  SPHI-PHI',
     * 7x,'RHO', 2x,'LAMBDA-1',2x,' ISPHI')           
c      :                                                              
c      correction term c ( X ) = v * G ( X ) computation                         
       do 100 i = 1 , Ip                                                   
       c ( i ) = Vd ( i , i ) * G ( i )
 100   continue 
c      :                                                              
c      :                                                              
c      :                                                              
c      + ================================= <150                         
c      :                                                              
  150  continue     
       iit = 0                                                           
c      :                                                              
c       + --------------<1210                                           
c      :                                                              
 1210  continue  
       do 210 i = 1 , Ip                                                   
         sx ( i ) = X ( i ) - c ( i )
 210   continue 
       isphiy = isphix 
corrected2000.10.20  1 line correction made by M.I.
c       isphix = 1 
       isphix = 0 
c      SPHI = val ,  sg = gradient computation 
       call numdif ( Model , sx , Ip ,  El , lel , sg , Vd , 1 , Step )
       SPHI = El (1)
c      :                                                              
c      ................................                                
         if( lel .le. 0)   then 
            iit = iit + 1          
               if( iit .gt. 10) then                                   
c                  ********  *                                              
                  Lcode =  72 
                  if( lpswmpi .ge. 2)
     *               write(6,*) 'B2:Initial search failed.'             
                  goto 1000 
c                 ------------------------- >1000                      
               end if                                                 
            do 304 i = 1 , Ip                                             
               c ( i ) = cst05 * c ( i )        
               do 303 j = 1 , Ip                                          
            Vd ( i , j ) = cst05 * Vd ( i ,  j )
 303        continue 
 304        continue 
            goto 1210                                                
c           ------------------------- >1210                            
         end if                                                       
c      ...............................
c      :                                                              
c      :                                                              
c      sr = v * sg                                                         
       do 310 i = 1 , Ip         
         sum = 0.d0                                
         do 311 j = 1 , Ip                                                
            sum = sum + Vd ( i , j ) * sg ( j )
 311     continue 
         sr ( i ) = sum 
 310   continue 
c      :                                                              
c      :                                                              
c      sro = ( sg )' * ( sr )                                                         '
       call innerp ( sg , sr , sro , Ip )
       arod = sro                                                        
       if( arod .lt. 0.d0) arod =  - arod                                   
       call innerp ( G , sr , gsr , Ip )   
c      :                                                              
c      :                                                              
c      maximization !                                                  
       if( PHI.lt. SPHI) then                                          
         do 560  i = 1 , Ip                                               
            X ( i ) = sx ( i )                                                
            G ( i ) = sg ( i )                                                
  560    continue                                                     
         val =  SPHI                                                    
       end if                                                          
c      :                                                              
c      :                                                              
c      convergence check 
c      ................................                             
       if( arod.lt.rhomin ) then                                         
c         **********                                                    
         Lcode  =  0                                                   
  608    format(1x  , 'B2:Bill ended with abs(RHO) =',f8.5,' < ',f8.5,
     *   ' = rhomin: code =',I3)                   
         if( lpswmpi .ge. 2) then                                            
            if( lpswmpi .eq. 3) write(6,609) NCOUNT , PHI , 
     *      SPHI - PHI , sro 
  609       format(1x ,'B3:',i5,f16.2,3x,f12.4,f12.4)                    
            write(6,608) arod , rhomin , Lcode                     
         end if                                                          
         goto 1000                                                   
c         =============================== >1000                         
       end if                                                          
c      ................................                             
c      :                                                              
c      iteration count check 
c      ................................                             
       if( limitx .gt. 0 .and. NCOUNT .gt. limitx ) then    
c         **********                                                    
         Lcode  =  50 
         if( lpswmpi .ge. 2) then                                            
            if( lpswmpi .eq. 3) write(6,609) NCOUNT , PHI , 
     *      SPHI - PHI ,
     *       sro         
            write(6,'('' B3:NCOUNT reached given limit'',I7)')
     *      limitx                     
         end if                                                          
         goto 1000                                                   
c         =============================== >1000                         
       end if                                                          
c      ................................                             
c      :                                                              
c      :                                                              
       dgam =  - gsr / sro                                                   
       dgam1 = dgam + cst1                                                 
       dgam1 = dabs ( dgam1) + 0.1d - 70                                       
       ram = dabs ( dgam ) / dgam1                                            
       if( ram.le.consta )   then                                        
         ram = consta                                                   
corrected2000.10.20  1 line correction made by M.I.
c         isphix  =  0 
         if( isphiy .ne. -1) isphix  =  1 
       end if                                                          
       if( ram.ge.constb )   then                                        
         ram = constb                                                   
corrected2000.10.20  1 line correction made by M.I.
c         isphix  =  0 
         if( isphiy .ne. 1) isphix  =  -1 
       end if                                                          
       ram1 = ram - cst1 
       ramlog  =  dlog ( ram )
corrected2000.10.20  1 line correction made by M.I.
c       ISPHI  =   ISPHI + isphiy 
       if( isphiy .eq. 0 ) ISPHI = ISPHI + 1 
       if( PHI .lt.  SPHI)  ISPHI = 0                                          
       if( lpswmpi .eq. 3) then                                            
         write(6,66) NCOUNT ,  PHI ,   SPHI - PHI , sro ,
     *   ram1 , ISPHI        
   66    format(1x ,'B3:',i5,f16.2,3x,f12.4,f12.4,f8.2,i6)                    
       end if                                                          
c      ................................                             
c      :                                                              
c      :                                                              
c      ................................                             
       if( dabs ( ramlog ) .lt. ramlim ) then                            
c         **********                                                 
         Lcode  =  70                                                
         if( lpswmpi .ge. 2) 
     *      write(6,600) dabs ( ramlog ) ,  ramlim , Lcode                 
  600       format(1x ,'B2:Bill ended with abs(log LAMBDA) = ', f6.2 ,         
     *      ' <',f6.2,'  =  ramlim: code  = ',I3)                                  
         goto 1000                                                
c        ------------------------- >1000                            
       end if                                                       
c      ................................                             
c      :                                                              
c      :                                                              
c      ................................                             
       if( ISPHI.ge.isplim ) then                                    
c         **********                                                 
         Lcode  =  71                                                
  603    format(1x ,'B2:Bill ended with  ISPHI  = ', i5,
     *              '  =  isplim: code  = ',I3) 
         if( lpswmpi .gt. 1) write(6,603)  ISPHI , Lcode                       
         goto 1000                                                
c        ------------------------- >1000                            
       end if                                                       
c      ................................                             
c      :                                                              
c      :                                                              
       ramsro = ram1 / sro                                                 
       do 481 i = 1 , Ip                                                   
         ramt = ramsro * sr ( i )                                            
         do 480 j = 1 , Ip                                                
            Vd ( i , j ) = Vd ( i , j ) + ramt * sr ( j )
 480      continue 
 481   continue 
c      :                                                              
c      :                                                              
c      maximization !                                                  
       if( SPHI .gt.  PHI) then                                          
c        : success 
         PHI =  SPHI                                                   
         do 545 i = 1 , Ip                                                
            c ( i ) = ram * sr ( i )
 545     continue 
       else                                                            
c        ................................                             
c         SPHI.le. PHI: test of correction                            
         consdr = dgam * ram1                                             
         do 550 i = 1 , Ip                                                
            c ( i ) = c ( i ) - consdr * sr ( i )
 550     continue 
c        ................................                             
       end if                                                          
c      : 
c      :                                                              
       itn = itn + 1                                                       
       goto 150                                                       
c      ================================= >150                          
c                                                                     
c      end of maximization                                             
c      + ================================== <1000                     
 1000  continue                                                        
       goto 9100 
      end                                                             

checkpoint:     lano =    77/129/sp2.@990422.@152623 ........
contents    11.3  numdif              
c reusable
      subroutine numdif ( Model , Est , Me , El , Lel , G , H , Icnt ,
     * Step )
       implicit real * 8 ( a-h , o-z )                                  
#ifdef MODIFIER
#include "ardock.env"
#endif
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       common  /cdall/ NCOUNT , limitx , lpswmpi 
       parameter ( LOCWORK = 1000)
c      !!   NOTE                                               !!
c      !!       LOCWORK should be greater than or equal me.    !!
c      !!                                                      !!
       dimension Els ( LOCWORK * 2 + 1), ivals ( LOCWORK * 2 + 1)
       dimension El (1) , G ( Me ) , H ( Me , Me ) , Est ( Me ) ,
     * Step ( Me ) 
       external Model 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
c      - 1998.5   mask option 
       dimension q ( LOCWORK )
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ........................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c         several minor changes. The most crucial one is handling 
c         of Model output lel. Now ,  it should be:
c           Lel > 0 if Model is successfully evaluated , 
c               = 0 if Model can not be evaluated.          
c      version - 0     1998.12 
c      numdif 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      function       - numerical differentiation.                       
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          El (1) = Elx 
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('numdif', io , stio )
          call showm ('I',
     i    ' Executes  numerical differentiation (D.109).')
          call showr ('I','Est' , Est    , 1 , 1 , Me )
          call showi ('I','Me' ,  Me     , 1 , 1 , 1)
          call showi ('I','Icnt', Icnt   , 1 , 1 , 1)
          call showr ('I','Step', Step   , 1 , 1 , Me )
          call showr ('O','El' , El      , 1 , 1 , 1)
          call showi ('O','Lel', Lel     , 1 , 1 , 1)
          call showr ('O','G' ,  G      ,  1 , 1 , Me )
          call showr ('O','H' ,  H      ,  Me , Me , Me )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          call areachk (
     i    'numdif' , 'LOCWORK' , LOCWORK , Me , 1 ,
     o    ierr ) 
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      :                                                              
       NCOUNT  =  NCOUNT + 1                       
       ista = 1 
       iend = Me  *  2 + 1 
#ifdef MPI
       call mpion (
     o mpiflag )
       if( mpiflag .eq. 1) then 
         call mpison (
     i   1 , Me  *  2 + 1 , 
     o   ista , iend )
       end if 
#endif
       do 1496 jx = ista , iend 
         j  =  jx 
         if( jx .gt. 1) then 
           j  =  jx / 2 
           jp  =  jx - j * 2 
           epsxsc = Step ( j )                                        
           eps2sc = epsxsc ** 2                                             
           estj = Est ( j )                                                  
           if( jp .eq. 0) then 
              Est ( j ) = estj - epsxsc 
#ifdef        AUTHOR
              if( mAINT .eq. 1 ) then 
c             - 1998.5   mask option 
                 call set (1 , q , ipq , Est , Me )
                 call Model ( q , ipq , El , lelm )
              else
                 call Model ( Est , Me , El , lelm )
              end if
#else
              call Model ( Est , Me , El , lelm )
#endif
              fmd = El (1)
              Els ( jx )  =  fmd 
              ivals ( jx )  =  lelm 
           else                                    
              Est ( j ) = estj + epsxsc 
#ifdef        AUTHOR
              if( mAINT .eq. 1 ) then 
c             - 1998.5   mask option 
                 call set (1 , q , ipq , Est , Me )
                 call Model ( q , ipq , El , lelp )
              else
                 call Model ( Est , Me , El , lelp )
              end if
#else
              call Model ( Est , Me , El , lelp )
#endif
              fpd = El (1)      
              Els ( jx )  =  fpd 
              ivals ( jx )  =  lelp 
           end if 
           Est ( j )  =  estj 
         else 
#ifdef     AUTHOR 
           if( mAINT .eq. 1 ) then 
c          - 1998.5   mask option 
              call set (1 , q , ipq , Est , Me )
              call Model ( q , ipq , El , Lel ) 
           else 
              call Model ( Est , Me , El , Lel )      
           end if      
#else
           call Model ( Est , Me , El , Lel )      
#endif
           Elx = El (1)
           Els (1)  =  Elx 
           ivals (1)  =  Lel 
         end if 
 1496  continue    
#ifdef MPI 
       call mpioff (
     i mpiflag )
       if( mpiflag .eq. 1) then 
         len = iend - ista + 1 
         call mpisoff (
     i   Els ( ista ) , len , MPI_DOUBLE_PRECISION , 
     o   Els )
         call mpisoff (
     i   ivals ( ista ) , len , MPI_INTEGER , 
     o   ivals )
       end if 
#endif 
       Elx  =  Els (1)
       Lel  =  ivals (1)
       if( Lel .le. 0) goto 9100 
c      ----------------------- 
#ifdef AUTHOR                                            
c      before 1997.8 M.I. 
       call wrhist ( Est , Elx , lpswmpi )
#endif                                        
      if( Icnt .eq. 0) goto 9100                                          
c     ------------------------- >return                              
c      :                                                              
       do 1 j = 1 , Me                                                    
         epsxsc = Step ( j )                                        
         eps2sc = epsxsc  ** 2                                           
         fmd  =  Els ( j  * 2)
         lelm  =  ivals ( j  * 2)
         fpd  =  Els ( j  * 2 + 1)
         lelp  =  ivals ( j  * 2 + 1)
         if( lelm .le. 0) then                                          
            if( lelp .le. 0) then                                       
               fmd  =  Elx                                                
               fpd  =  Elx                                                
            else                                                      
               if( fpd .gt. Elx ) then                                    
                  fmd  =  2.d0 *  Elx - fpd                                
               else                                                   
                  fmd  =  Elx                                             
                  fpd  =  Elx                                             
               end if                                                 
            end if                                                    
         else                                                         
            if( lelp .le. 0) then                                       
               if( fmd .gt. Elx ) then                                    
                  fpd  =  2.d0 *  Elx - fmd                                
               else                                                   
                  fmd  =  Elx                                             
                  fpd  =  Elx                                             
               end if                                                 
            end if                                                    
         end if                                                       
c        :                                                            
         G ( j ) = ( fpd - fmd ) /  epsxsc  * 0.5d0 
c        :                                                            
         if( Icnt .ge. 2) then                                         
            do 2 i = 1 , Me                                               
            H ( i , j ) = 0.0d0 
 2          continue 

            H ( j , j ) = ( fpd + fmd - Elx  * 2.d0) /  eps2sc 
         end if                                                       
c        :                                                            
    1  continue                                                        
       Lel  =  1 
       goto 9100 
      end 

checkpoint:    lano =    78/129/sp2.@990422.@152623 ........
contents    11.4  innerp              
c reusable
      subroutine innerp ( Dd1 , Dd2 , Dinp12 , Id )                            
       implicit real*8 ( a-h , o-z )                                     
       dimension Dd1 (1) , Dd2 (1)                                         
c      ........................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c      version - 0     1998.12 
c      innerp 
c      Computation of the inner product.
       sum = 0.0d - 00                                                     
       do 100 i = 1 , Id                                                   
         sum = sum + Dd1 ( i ) * Dd2 ( i )
 100   continue 
       Dinp12 = sum                                                      
       return                                                          
      end                                                             

checkpoint:   lano =    79/129/sp2.@990422.@152623 ........
contents    11.5  lftint              
c reusable
      function lftint ( X )                                              
       implicit real * 8 ( a-h , o-z )                                    
c      ........................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c      version - 0     1998.12 
c      lftint 
c      Find the largest integer less than or equal to X.
       if( X .lt. 0.d0) then                                      
          tem = X                                                           
          ix =  - X                                                           
          ix = ix + 1                                                         
          tem = tem + ix                                                    
          lftint  =  tem                                                    
          lftint  =  lftint - ix                                            
       else 
          lftint  =  X 
       end if                                                     
       return                                                          
      end                                                             

checkpoint:  lano =    80/129/sp2.@990422.@152623 ........
contents    11.6  eval                
c reusable
      subroutine eval (
     i Model , el , Xi , Xe , M , Ndata ,  
     o Y, Rlim , 
     w D , X , Q )
       implicit real * 8 ( a - h,o - z )
#ifdef MODIFIER
#include "ardock.env"
#endif
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       common  /cdall/ NCOUNT , limitx , lpswmpi                  
       dimension el (1) , Y( Ndata ) , Xi ( M ) , Xe ( M ) , 
     * D ( M ) , X ( M ) ,
     * Q ( M ) 
       external Model 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
c      ........................................................
c      history 
c      version       date         location 
c      F_MPI_1       1996.11      ISMLIB   
c         several minor changes. The most crucial one is handling 
c         of Model output lel. Now ,  it should be:
c           Lel > 0 if Model is successfully evaluated , 
c               = 0 if Model can not be evaluated.          
c      version - 0     1998.12 
c      eval 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('eval', io , stio )
          call showm ('I',
     i    ' Evaluate a function along a line in the parameter space.')
          call showr ('I','Xi' ,    Xi    , 1 , 1 , M )
          call showr ('I','Xe' ,    Xe    , 1 , 1 , M )
          call showi ('I','M' ,     M     , 1 , 1 , 1)
          call showi ('I','Ndata' , Ndata , 1 , 1 , 1)
          call showr ('O','Y' ,     Y    ,  1 , 1 , Ndata )
          call showr ('O','Rlim' ,  Rlim  , 1 , 1 , 1)
          call showw ('el',  1, 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 1 i = 1 , M 
         D ( i ) = ( Xe ( i ) - Xi ( i )) / ( Ndata - 1)
    1  continue 
       ista = 1 
       iend = Ndata 
#ifdef MPI                      
       call mpion (
     o mpiflag )
       if( mpiflag .eq. 1) then 
         call mpison (
     i   1 , Ndata , 
     o   ista , iend )
       end if 
#endif
       do 2 j = ista , iend 
         do 3 i = 1 , M     
            X ( i ) = Xi ( i ) + D ( i ) * ( j - 1) 
    3    continue 
#ifdef   AUTHOR 
         if( mAINT .eq. 1 ) then 
c        - 1998.5   mask option 
            call set (1 , Q , ipq , X , M )
            call Model ( Q , ipq , el , Lel )
         else 
            call Model ( X , M , el , Lel )
         end if 
#else
         call Model ( X , M , el , Lel )
#endif
         Y( j ) = el (1)                
            if( Lel .le. 0) then  
               Rlim = 1.d40 
               Y( j ) = 1.d41  
            end if 
    2  continue                                                        
#ifdef MPI 
       call mpioff (
     i mpiflag )
       if( mpiflag .eq. 1) then 
          call mpisoff (
     i    Y( ista ) , iend - ista + 1 , MPI_DOUBLE_PRECISION , 
     o    Y)
       end if 
#endif 
       goto 9100 
      end                                                             

checkpoint: lano =    81/129/sp2.@990422.@152623 ........
contents  12. kalman               subpackage
contents    12.1  kalman              
c reusable
      subroutine kalman (
     i Y , Rlim , G , Sigv , Sigr , Vf , Irf , Icf , Nf , Vh , Irh , 
     i Ich ,
     I Nh , N0 , Iy , Iv , Iz , Ndata , My , Mv , Mz , Mn , 
     a Z , V , 
     o El , Lel )
       implicit real*8 ( a-h , o-z )  
#include "ardock.env"
       dimension Z ( Mz , 0: Mn ) ,  V ( Mz , Mz , 0: Mn ) , El (1)
       dimension G ( Mz , Mv ) , Sigv ( Mv , Mv ) , 
     * Sigr ( My , My ) , Y ( Mn , My )  
       dimension Icf ( Nf ) , Irf ( Nf ) , Vf ( Nf ) 
       dimension Ich ( Nh ) , Irh ( Nh ) , Vh ( Nh )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      kalman 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('kalman', io , stio )                  
          call showm3 ('I',
     i    ' Executes Kalman filtering procedure.',
     i    ' See p.34 and Appendix C of CSM.',
     i    ' Calls kalmaw.')
          call showr ('I','Y' ,    Y ,       Mn , Mn , My )    
          call showr ('I','Rlim' , Rlim ,    1 , 1 , 1)
          call showr ('I','G' ,    G ,       Mz , Mz , Mv )
          call showr ('I','Sigv' , Sigv ,    Mv , Mv , Mv )
          call showr ('I','Sigr' , Sigr ,    My , My , My )
          call showr ('I','Vf' ,   Vf ,      1 , 1 , Nf )    
          call showi ('I','Irf' ,  Irf ,     1 , 1 , Nf )    
          call showi ('I','Icf' ,  Icf ,     1 , 1 , Nf )
          call showi ('I','Nf' ,   Nf ,      1 , 1 , 1)
          call showr ('I','Vh' ,   Vh ,      1 , 1 , Nh )
          call showi ('I','Irh' ,  Irh ,     1 , 1 , Nh )    
          call showi ('I','Ich' ,  Ich ,     1 , 1 , Nh )    
          call showi ('I','Nh' ,   Nh ,      1 , 1 , 1)
          call showi ('I','N0' ,   N0 ,      1 , 1 , 1)
          call showi ('I','Iy' ,   Iy ,      1 , 1 , 1)    
          call showi ('I','Iv' ,   Iv ,      1 , 1 , 1)
          call showi ('I','Iz' ,   Iz ,      1 , 1 , 1)    
          call showi ('I','Ndata', Ndata ,   1 , 1 , 1)
          call showi ('I','My' ,   My ,      1 , 1 , 1)
          call showi ('I','Mv' ,   Mv ,      1 , 1 , 1)    
          call showi ('I','Mz' ,   Mz ,      1 , 1 , 1)
          call showi ('I','Mn' ,   Mn ,      1 , 1 , 1)    
          call showr ('I','Z' ,    Z ,       Mz , Mz , Mn + 1)    
          call showr ('I','V' ,    V ,       Mz , Mz , Mz )
          call showr ('O','Z' ,    Z ,       Mz , Mz , Mn + 1)    
          call showr ('O','V' ,    V ,       Mz , Mz , Mz )
          call showr ('O','El' ,   El ,      1 , 1 , Mn + 1)    
          call showi ('O','Lel' ,  Lel ,     1 , 1 , 1)    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      set icnt = 1 if smoothed estimate is required 
c      then smoothed estimate and its covariance is returened 
c      in Z and V ,  respectively.
       icnt  =  0 
       call kalmaw (
     i Y , Rlim , G , Sigv , Sigr , Vf , Irf , Icf , Nf , Vh , 
     i Irh , Ich , 
     i Nh , N0 , Iy , Iv , Iz , Ndata , My , Mv , Mz , Mn , 
     i icnt , 
     a Z , V , 
     o El , Lel , 
     w wk ( nw ('aph' , Mz * My )) ,  wk ( nw ('ak' , Mz * My )) ,  
     w wk ( nw ('pinv' , Mz * Mz )) , 
     w wk ( nw ('c' , Mz * Mz )) ,  wk ( nw ('ztem' , Mz )) ,  
     w wk ( nw ('zt' , Mz )) , 
     w wk ( nw ('pt' , Mz * Mz * Mn )) ,  
     w wk ( nw ('GSigvG' , Mz * Mz )) ,  
     w wk ( nw ('q' , My * My )) ,  
     w wk ( nw ('dy' , My )) ,  wk ( nw ('cc' , Mz * Mz )) , 
     w iwk ( iw ('miss' , My )), iwk ( iw ('niss' , My )), 
     w iwk ( iw ('ich' , Nh )), iwk ( iw ('irh' , Nh )),
     w wk ( nw ('vh' , Nh )))
       goto 9100 
      end 

checkpoint:  lano =    82/129/sp2.@990422.@152623 ........
contents    12.2  kalmaw             
c reusable
      subroutine kalmaw (
     i Y , Rlim , G , Sigv , Sigr , Vf , Irf , Icf , Nf , Vh0 , 
     i Irh0 , Ich0 , 
     i Nh0 , N0 , Iy0 , Iv , Iz , Ndata , My , Mv , Mz , Mn , 
     i Icnt , 
     a Z , V , 
     o El , Lel , 
     w vtf , ak , vinv , c , ztem , zt , vt , gsigvg , 
     w q , dy , cc , miss , niss , ich , irh , vh )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension El ( Mn + 1)  
       dimension  Z ( Mz , 0: Mn ) , V ( Mz , Mz , 0: Mn ) , 
     * G ( Mz , Mv ) 
       dimension  Sigv ( Mv , Mv ) , Sigr ( My , My ) , 
     * Y ( Mn , My ) , miss ( My )  
       dimension Icf ( Nf ) , Irf ( Nf ) , Vf ( Nf ) 
       dimension Ich0 ( Nh0) , Irh0 ( Nh0) , Vh0 ( Nh0)  
       dimension ich ( Nh0 ) , irh ( Nh0 ) , vh ( Nh0 ) , 
     * niss ( My )  
       dimension  vtf ( Mz , My ) , ak ( Mz , My ) , 
     * vinv ( Mz , Mz ) , 
     * c ( Mz , Mz ) , ztem ( Mz ) 
       dimension  zt ( Mz ) ,  vt ( Mz , Mz , Mn ) , 
     * gsigvg ( Mz , Mz ) , 
     * q ( My , My ) ,  dy ( My ) ,  cc ( Mz , Mz )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init  / 1 /, pi /0.d0/
c      ........................................................
c      kalmaw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      Set Icnt = 1 if smoothed estimate is required.
c      Smoothed estimate and its covariance are returened 
c      in Z and V ,  respectively.
       call areachk ('kalmaw','{',0,0,0,
     o ierr )
       if( ierr .eq. 1) goto 9199
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('kalmaw', io , stio )
          call showm2 ('I',
     i    ' Executes Kalman filtering procedure.',
     i    ' See p.34 and Appendix C of CSM.')
          call showr ('I','Y' ,    Y ,       Mn , Mn , My )    
          call showr ('I','Rlim' , Rlim ,    1 , 1 , 1)
          call showr ('I','G' ,    G ,       Mz , Mz , Mv )
          call showr ('I','Sigv' , Sigv ,    Mv , Mv , Mv )
          call showr ('I','Sigr' , Sigr ,    My , My , My )
          call showr ('I','Vf' ,   Vf ,      1 , 1 , Nf )    
          call showi ('I','Irf' ,  Irf ,     1 , 1 , Nf )    
          call showi ('I','Icf' ,  Icf ,     1 , 1 , Nf )
          call showi ('I','Nf' ,   Nf ,      1 , 1 , 1)
          call showr ('I','Vh0' ,  Vh0 ,     1 , 1 , Nh0 )
          call showi ('I','Irh0' , Irh0 ,    1 , 1 , Nh0 )    
          call showi ('I','Ich0' , Ich0 ,    1 , 1 , Nh0 )    
          call showi ('I','Nh0' ,  Nh0 ,     1 , 1 , 1)
          call showi ('I','N0' ,   N0 ,      1 , 1 , 1)
          call showi ('I','Iy0' ,  Iy0 ,     1 , 1 , 1)    
          call showi ('I','Iv' ,   Iv ,      1 , 1 , 1)
          call showi ('I','Iz' ,   Iz ,      1 , 1 , 1)    
          call showi ('I','Ndata', Ndata ,   1 , 1 , 1)
          call showi ('I','My' ,   My ,      1 , 1 , 1)
          call showi ('I','Mv' ,   Mv ,      1 , 1 , 1)    
          call showi ('I','Mz' ,   Mz ,      1 , 1 , 1)
          call showi ('I','Mn' ,   Mn ,      1 , 1 , 1)    
          call showr ('A','Z' ,    Z ,       Mz , Mz , Mn + 1)    
          call showr ('A','V' ,    V ,       Mz , Mz , Mz )
          call showr ('O','El' ,   El ,      1 , 1 , Mn + 1)    
          call showi ('O','Lel' ,  Lel ,     1 , 1 , 1)    
          call showw ('aph' ,  Mz ,      My )
          call showw ('ak' ,   Mz ,      My )
          call showw ('pinv' , Mz ,      Mz )
          call showw ('c' ,    Mz ,      Mz )
          call showw ('ztem' , 1 ,       Mz )
          call showw ('zt' ,   1 ,       Mz )
          call showw ('pt' ,   Mz ,      Mz )
          call showw ('qq' ,   Mz ,      Mz )
          call showw ('q' ,    My ,      My )
          call showw ('dy' ,   1 ,       My )
          call showw ('cc' ,   Mz ,      Mz )
          call showw ('miss' , 1 ,       My )
          call showw ('niss' , 1 ,       My )
          call showw ('irh',   1 ,       nh0 )
          call showw ('ich',   1 ,       nh0 )
          call showw ('vh',    1 ,       nh0 )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9199  continue 
       Lel = 0 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init = 0 
          pi  =  atan2 (0.d0 ,  - 1.d0) 
       end if 
       El (1) = 0.d0 
       do 1000 i = 1 , Iz 
       do 1002 j = 1 , i 
          sum = 0.d0 
          do 5003 l = 1 , Iv   
          do 1003 m = 1 , Iv   
             sum = sum + G ( i , l ) * Sigv ( l , m ) * G ( j , m ) 
 1003     continue 
 5003     continue 
          gsigvg ( i , j ) = sum 
          if( j.lt.i ) gsigvg ( j , i ) = sum 
 1002  continue               
 1000  continue     
c      main loop 
       nh9  =  0 
       Lel  =  0 
       do 2000 k = 1 , Ndata  
c         prediction 
          call clr (
     i    Iz , 1 , Mz , 1 , 
     o    zt )   
          call left (
     i    1.d0 , Vf , Z (1 , k - 1) , 1 , Mz , 1 , Nf , Irf , Icf , Mz ,
     i    1 , 
     a    zt ) 
          do 5200 i = 1 , Iz 
          do 2200 j = 1 , Iz 
             vt ( i , j , k ) = gsigvg ( i , j )
 2200     continue 
 5200     continue 
          call both (
     i    Vf , V (1 , 1 , k - 1) , Mz , Mz , Nf , Irf , Icf , Mz , Mz , 
     a    vt (1 , 1 , k ))  
c         loglikelihood computation 
          if( Rlim .ne. 0.d0 .or. nh9 .eq. 0) then 
             nh9  =  1 
             iy  =  0 
             do 2301 i = 1 , Iy0 
                niss ( i ) = 0 
                if( Rlim .eq. 0.d0 .or. Y ( k , i ) .lt. Rlim ) then 
                   iy  =  iy + 1 
                   miss ( iy )  =  i 
                   niss ( i )  =  iy 
                end if 
 2301        continue 
             nh  =  0 
             do 2302 ih = 1 , Nh0 
                if( niss ( Irh0 ( ih )) .ne. 0) then 
                   nh  =  nh + 1 
                   irh ( nh )  =  niss ( Irh0 ( ih ))
                   ich ( nh )  =  Ich0 ( ih )
                   vh ( nh )  =  Vh0 ( ih )
                end if 
 2302        continue 
          end if 
          if( iy .le. 0) then 
             do 6700 i = 1 , Iz  
                Z ( i , k ) = zt ( i )
 6700        continue 
             do 6801 i = 1 , Iz 
             do 6800 j = 1 , Iz 
                V ( i , j , k ) = vt ( i , j , k )
 6800        continue 
 6801        continue 
             goto 2000 
c            ========= 
          end if 
c         ------
          do 5300 i9 = 1 , iy 
             i  =  miss ( i9) 
             do 2300 j9 = 1 , iy 
                j  =  miss ( j9)
                q ( i9 , j9) = Sigr ( i , j ) 
 2300        continue 
 5300     continue 
          call both (
     i    vh , vt (1 , 1 , k ) , My , My , nh , irh , ich , Mz , Mz , 
     a    q )
          do 2400 i9 = 1 , iy 
             i  =  miss ( i9) 
             dy ( i9) = Y ( k , i )
 2400     continue 
          call left (
     i     - 1.d0 , vh , zt , 1 , My , 1 , nh , irh , ich , Mz , 1 , 
     a    dy )
          call invmat (
     i    iy , My , 
     a    q , 
     o    detq , ier )
          if( ier .ne. 0) goto 9199 
c         ------------------------
          if( k .gt. N0 ) then  
             omega = 0.d0  
             do 5500 i = 1 , iy 
             do 2500 j = 1 , iy 
                omega = omega + dy ( i ) * q ( i , j ) * dy ( j ) 
 2500        continue 
 5500        continue 
             Eltem = - 0.5d0 * ( iy * dlog (2 * pi ) + 
     *       dlog ( detq ) + omega )
             Lel  =  Lel + 1 
             El ( Lel + 1) = Eltem 
             El (1) =  El (1) + Eltem 
          end if 
          call clr (
     i    Iz , iy , Mz , My , 
     o    vtf ) 
          call right (
     i    1.d0 , vh , vt (1 , 1 , k ) , Iz , Mz , My , nh , ich , irh , 
     i    Mz , Mz , 
     a    vtf )  
          do 5600 i = 1 , Iz 
          do 2600 j = 1 , iy 
             sum = 0.d0 
             do 2630 m = 1 , iy   
                sum = sum + q ( m , j ) * vtf ( i , m ) 
 2630        continue      
             ak ( i , j ) = sum 
 2600     continue 
 5600     continue 
          do 2700 i = 1 , Iz 
             sum = zt ( i )
             do 2710 j = 1 , iy   
                sum = sum + ak ( i , j ) * dy ( j ) 
 2710        continue      
             Z ( i , k ) = sum 
 2700     continue 
          do 5800 i = 1 , Iz 
          do 2800 j = 1 , i   
             sum = vt ( i , j , k )  
             do 2810 l = 1 , iy   
                sum = sum - ak ( i , l ) * vtf ( j , l )
 2810        continue 
             if( j.lt.i ) V ( j , i , k ) = sum 
             V ( i , j , k ) = sum 
 2800     continue 
 5800     continue 
          do 2801 i = 1 , Iz 
             if( V ( i , i , k ) .le. 0.d0) then                          
c               negative V ( i , i , k )                  
                do 2802 j = 1 , Iz 
                   V ( i , j , k ) = 0.d0 
                   V ( j , i , k ) = 0.d0 
 2802           continue        
             end if   
 2801     continue     
 2000  continue 
       if( Icnt .eq. 0) goto 9100 
c      ------------------------- 
       do 3000 k = Ndata - 1 , 1 ,  - 1 
          do 5100 i = 1 , Iz 
          do 3100 j = 1 , Iz 
             vinv ( i , j ) = vt ( i , j , k + 1)
 3100     continue 
 5100     continue 
          call invmat (
     i    Iz , Mz , 
     a    vinv , 
     o    detq , ier )
          call clr (
     i    Iz , Iz , Mz , Mz , 
     o    cc )  
          call left (
     i    1.d0 , Vf , vinv , Iz , Mz , Mz , Nf , Icf , Irf , Mz , Mz , 
     a    cc )
          do 3201 i = 1 , Iz 
          do 3200 j = 1 , Iz 
             sum = 0.d0 
             do 3210 m = 1 , Iz   
                sum = sum + V ( i , m , k ) * cc ( m , j )
 3210        continue 
             c ( i , j ) = sum 
 3200     continue 
 3201     continue 
          do 3300 i = 1 , Iz 
             ztem ( i ) = Z ( i , k + 1) 
 3300     continue 
          call left (
     i     - 1.d0 , Vf , Z (1 , k ) , 1 , Mz , 1 , Nf , Irf ,
     i    Icf , Mz , 1 , 
     a    ztem )
          do 3400 i = 1 , Iz 
             sum = Z ( i , k ) 
             do 3410 j = 1 , Iz   
                sum = sum + c ( i , j ) * ztem ( j ) 
 3410        continue       
             Z ( i , k ) = sum 
 3400     continue 
          do 3501 i = 1 , Iz 
          do 3500 j = 1 , i 
             sum = V ( i , j , k )
             do 5502 l = 1 , Iz   
                sum = sum + c ( i , l ) * ( V ( l , m , k + 1) - 
     *          vt ( l , m , k + 1)) * c ( j , m )
 5502        continue 
             if( j.lt.i ) V ( j , i , k ) = sum 
             V ( i , j , k ) = sum 
 3500     continue 
 3501     continue 
 3000  continue 
       goto 9100 
      end 

checkpoint:   lano =    83/129/sp2.@990422.@152623 ........
contents    12.3  both                
c reusable
      subroutine both (
     i Va , C , Irb , Icb , Na , Ira , Ica , Irc , Icc , 
     a B )      
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension B ( Irb , Icb ) , Ira (1) , Ica (1) , Va (1) , 
     * C ( Irc , Icc )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      both 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'i'
 9100  continue 
#ifdef MODIFIER
       myself = 9   
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('both', io , stio )
          call showm ('I',
     i    ' Executes computation $ B = A B A^T$.')
          call showr ('I','Va' ,  Va ,    1 , 1 , Na )
          call showr ('I','C' ,   C ,     Irc , Irc , Icc )
          call showi ('I','Irb' , Irb ,   1 , 1 , 1)
          call showi ('I','Icb' , Icb ,   1 , 1 , 1)
          call showi ('I','Na' ,  Na ,    1 , 1 , 1)
          call showi ('I','Ira' , Ira ,   1 , 1 , Na )
          call showi ('I','Ica' , Ica ,   1 , 1 , Na )
          call showi ('I','Irc' , Irc ,   1 , 1 , 1)
          call showi ('I','Icc' , Icc ,   1 , 1 , 1)     
          call showr ('A','B' ,   B ,     Irb , Irb , Icb )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 22 k = 1 , Na     
       do 2 l = 1 , Na     
          B ( Ira ( k ) , Ira ( l )) = B ( Ira ( k ) , Ira ( l )) + 
     *    Va ( k ) * C ( Ica ( k ) , Ica ( l )) * Va ( l ) 
    2  continue 
   22  continue 
       goto 9100 
      end  

checkpoint:    lano =    84/129/sp2.@990422.@152623 ........
contents    12.4  left                
c reusable
      subroutine left (
     i Const , Va , C , Icb , Mrb , Mcb , Na , Ira , Ica , Mrc , Mcc , 
     a B ) 
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension B ( Mrb , Mcb ) , Ira (1) , Ica (1) , Va (1) ,
     * C ( Mrc , Mcc )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      left 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'i'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('left', io , stio )
          call showm ('I',
     i    ' Executes computation B = A B')
          call showr ('I','Const' , Const ,   1 , 1 , 1)    
          call showr ('I','Va' ,    Va ,      1 , 1 , Na )
          call showr ('I','C' ,     C ,       Mrc , Mrc , Mcc )
          call showi ('I','Icb' ,   Icb ,     1 , 1 , 1)
          call showi ('I','Mrb' ,   Mrb ,     1 , 1 , 1)
          call showi ('I','Mcb' ,   Mcb ,     1 , 1 , 1)
          call showi ('I','Na' ,    Na ,      1 , 1 , 1)
          call showi ('I','Ira' ,   Ira ,     1 , 1 , Na )
          call showi ('I','Ica' ,   Ica ,     1 , 1 , Na )
          call showi ('I','Mrc' ,   Mrc ,     1 , 1 , 1)
          call showi ('I','Mcc' ,   Mcc ,     1 , 1 , 1)    
          call showr ('A','B' ,     B ,       Mrb , Mrb , Mcb )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 3 ic = 1 , Icb  
       do 2 k = 1 , Na     
          B ( Ira ( k ) , ic ) = B ( Ira ( k ) , ic ) + 
     *    Const * Va ( k ) *  C ( Ica ( k ) , ic )
    2  continue    
    3  continue 
       goto 9100 
      end  

checkpoint:     lano =    85/129/sp2.@990422.@152623 ........
contents    12.5  right               
c reusable
      subroutine right (
     i Const , Va , C , Irb , Mrb , Mcb , Na , Ira , Ica , Mrc , Mcc , 
     a B )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension B ( Mrb , Mcb ) , Ira (1) , Ica (1) , Va (1) , 
     * C ( Mrc , Mcc )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      right 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'i'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('right', io , stio )
          call showm ('I',
     i    ' Executes computation $ B = B A^T$.')
          call showr ('I','Const' ,Const ,   1 , 1 , 1)    
          call showr ('I','Va' ,   Va ,      1 , 1 , Na )
          call showr ('I','C' ,    C ,       Mrc , Mrc , Mcc )    
          call showi ('I','Irb' ,  Irb ,     1 , 1 , 1)
          call showi ('I','Mrb' ,  Mrb ,     1 , 1 , 1)
          call showi ('I','Na' ,   Na ,      1 , 1 , 1)
          call showi ('I','Ira' ,  Ira ,     1 , 1 , Na )
          call showi ('I','Ica' ,  Ica ,     1 , 1 , Na )
          call showi ('I','Mrc' ,  Mrc ,     1 , 1 , 1)
          call showi ('I','Mcc' ,  Mcc ,     1 , 1 , 1)
          call showr ('A','B' ,    B ,       Mrb , Mcb , Mcb )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 3 ir = 1 , Irb  
       do 2 k = 1 , Na     
          B ( ir , Ica ( k )) = B ( ir , Ica ( k )) + Const * Va ( k ) * 
     *    C ( ir , Ira ( k ))
    2  continue    
    3  continue 
       goto 9100 
      end  

checkpoint:      lano =    86/129/sp2.@990422.@152623 ........
contents    12.6  clr                 
c reusable
      subroutine clr (
     i Irb , Icb , Mrb , Mcb , 
     o B )                          
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension B ( Mrb , Mcb )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      clr 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'i'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('clr', io , stio )
          call showm ('I',
     i    ' Clears work array B.')
          call showi ('I','Irb' ,  Irb ,  1 , 1 , 1)
          call showi ('I','Icb' ,  Icb ,  1 , 1 , 1)
          call showi ('I','Mrb' ,  Mrb ,  1 , 1 , 1)
          call showi ('I','Mcb' ,  Mcb ,  1 , 1 , 1)
          call showr ('O','B' ,   B ,    Mrb , Irb , Icb )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 11 ic = 1 , Icb  
       do 1 ir = 1 , Irb  
          B ( ir , ic ) = 0.d0 
    1  continue 
   11  continue  
       goto 9100 
      end  


#ifdef MODIFIER
checkpoint:       lano =    87/129/sp2.@990422.@152623 ........
contents    12.7  fmatrix
c reusable                 
      subroutine fmatrix( 
     i Key , Vf, Irf , Icf, Nf , Iz )
       implicit real*8 (a-h,o-z)
#include "ardock.env"
       character*(*) Key 
       dimension mat (100,100), Irf ( Nf ), Icf ( Nf ), Vf (Nf )
c      .........................................................
c      fmatrix 
c      Copyright_OML 1999 M. Ishiguro 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Shows the structure of the matrix defines in Terms of  Vf, Irf,
c       Icf and Nf.
       goto 9200
 9100  continue 
       return
 9200  continue
       do 100 i = 1,100
       do 101 j = 1,100
          mat ( i , j ) = 0
  101  continue
  100  continue
       i20 = 0
       j75 = 0
       do 200 i = 1, nf 
          if( Irf ( i ) .le. 100 .and. Icf ( i ) .le. 100) then 
             if( Irf ( i ) .gt. i20 ) i20 = Irf ( i )
             if( Icf ( i ) .gt. j75 ) j75 = Icf ( i )
             mat ( Irf ( i ), Icf ( i )) = 10
          end if
  200  continue
       if( mYID .eq. 0) then
          write(6,*)
          write(6,*) 'The structure of matrix ', Key 
          if( i20 .gt. 20) i20 = 20
          if( j75 .gt. 75) j75 = 75       
          do 300 i = 1,i20
             write(6,'(1x, 75I1)') ( mat ( i , j ), j = 1,j75)
  300     continue 
          write(6,*)
       end if
       do 201 i = 1, nf 
          if( Irf ( i ) .le. 100 .and. Icf ( i ) .le. 100) then 
             mat ( Irf ( i ), Icf ( i )) = Vf ( i )
             if( mat ( Irf ( i ), Icf ( i )) .eq. 0) 
     *       mat ( Irf ( i ), Icf ( i )) = 1
          end if
  201  continue
       call bugnet(0,'i', Key , r , mat ,1,1,10,10,100, Iz )
       goto 9100
      end
#endif

#ifdef ARDOCKLINK
checkpoint:        lano =    88/129/sp2.@990422.@152623 ........
contents  13. sadjust              subpackage
contents    13.1  sadjust             
c ardock-specific
      subroutine sadjust (
     i Abuse , Nch , Iauto , Lpe , Ndata , Lagmax , 
     a Y , Trend , Season , 
     o Trinit , Vtrend , Vseas )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension Y ( Ndata ) , Trend ( Ndata ) , Season ( Ndata ) , 
     * Trinit (2)                         
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      sadjust 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0  =  nw ('}' , nw0)
          iw0  =  iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('sadjust', io , stio )                  
          call showm3 ('I',
     i    '1.Adjusts one dimensional time series data for trend',
     i    '  and seasonality by BAYSEA procedure (Appendix B). ',
     i    '2.Reserves work area and calls sadjuw. See p.35 of CSM.')
          call showr ('I','Abuse' ,  Abuse ,   1 , 1 , 1)
          call showi ('I','Nch' ,    Nch ,     1 , 1 , 1)
          call showi ('I','Iauto' ,  Iauto ,   1 , 1 , 1)
          call showi ('I','Lpe' ,    Lpe ,     1 , 1 , 1)
          call showi ('I','Ndata' ,  Ndata ,   1 , 1 , 1)
          call showi ('I','Lagmax' , Lagmax ,  1 , 1 , 1)    
          call showr ('I','Y' ,      Y ,       1 , 1 , Ndata )    
          call showr ('O','Trinit' , Trinit ,  1 , 1 , 2)
          call showr ('O','Vtrend' , Vtrend ,  1 , 1 , 1)
          call showr ('O','Vseas' ,  Vseas   , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0  =  nw ('{' , 0)
          iw0  =  iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       ia  =  Ndata 
       lenh  =  Ndata * (4 + 1)
       lenh2  =  Ndata * 2 + 1 
       mdc0  =  Ndata * 2 * (4 * 2 + 1)
       call sadjuw (
     i Abuse , Nch , Iauto , Lpe , Ndata , Lagmax , mdc0 ,
     i lenh , lenh2 , 
     a Y , Trend , Season , 
     o Trinit , Vtrend , Vseas , 
     w wk ( nw ('ftrn' , ia )) , wk ( nw ('fsea' , ia )) , 
     w wk ( nw ('psds' , ia )) , 
     w wk ( nw ('psdt' , ia )) ,  
     w wk ( nw ('irreg' , ia )) , 
     w wk ( nw ('f' , ia )) , 
     w wk ( nw ('h2' , lenh2)) , wk ( nw ('dc' , mdc0)) , 
     w wk ( nw ('h' , lenh )))
       goto 9100 
      end 
#endif

#ifdef ARDOCKLINK
checkpoint:         lano =    89/129/sp2.@990422.@152623 ........
contents    13.2  sadjuw            
c ardock-specific
      subroutine sadjuw (
     i Abuse , Nch , Iauto , Lpe , Ndata , Lagmax , Mdc ,
     i Lenh , Lenh2 , 
     a Y , Trend , Season , 
     o Trinit , Vtrend , Vseas , 
     w ftrn , fsea , psds , psdt , irreg , f , h2 ,
     w dc , h ) 
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       integer * 4  order ,  sorder ,  period 
       common  / ibaysea /  period , order , sorder , ifix 
       common  / rbaysea /  alpha , beta , gamma , zer , smth , smth2 ,
     * dd , wtrd 
       dimension Y ( Ndata )
       dimension Trinit (2)
       character*20 cpar , clab , ctem 
       dimension  dc ( Mdc ) 
       dimension  h ( Lenh ) , h2 ( Lenh2)
       dimension  ftrn ( Ndata ) , fsea ( Ndata ) , 
     * psds ( Ndata ) , psdt ( Ndata ) 
       dimension  Season ( Ndata ) ,  Trend ( Ndata ) 
       real * 8 irreg ( Ndata ) 
       dimension  f ( Ndata )
       character*1 ckey           
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
       data iguess  / 0 / 
c      .............................................
c      sadjuw 
c      version / date          location / memo 
c      version - 1 / 1998.12.17           / dmin0 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed. 
       call areachk (
     i 'sadjust','{',0,0,0,
     o ierr )
       call mpistop ( ierr )
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('sadjuw', io , stio )
          call showm3 ('I',
     i    'Adjusts one dimensional time series data for trend',
     i    'and seasonality by BAYSEA procedure (Appendix B).',
     i    'See p.35 of CSM.')
          call showr ('I','Abuse' ,  Abuse ,   1 , 1 , 1)
          call showi ('I','Nch' ,    Nch ,     1 , 1 , 1)
          call showi ('I','Iauto' ,  Iauto ,   1 , 1 , 1)
          call showi ('I','Lpe' ,    Lpe ,     1 , 1 , 1)
          call showi ('I','Ndata' ,  Ndata ,   1 , 1 , 1)
          call showi ('I','Lagmax' , Lagmax ,  1 , 1 , 1)    
          call showi ('I','Mdc' ,    Mdc ,     1 , 1 , 1)
          call showi ('I','Lenh' ,   Lenh  ,   1 , 1 , 1)
          call showi ('I','Lenh2' ,  Lenh2 ,   1 , 1 , 1)
          call showr ('A','Y' ,      Y ,       1 , 1 , Ndata )    
          call showr ('O','Trend' ,  Trend ,   1 , 1 , Ndata )    
          call showr ('O','Season' , Season ,  1 , 1 , Ndata )    
          call showr ('O','Trinit' , Trinit ,  1 , 1 , 2)
          call showr ('O','Vtrend' , Vtrend ,  1 , 1 , 1)
          call showr ('O','Vseas' ,  Vseas   , 1 , 1 , 1)
          call showw ('ftrn' ,   1 ,       Ndata )
          call showw ('fsea' ,   1 ,       Ndata )
          call showw ('psds' ,   1 ,       Ndata )
          call showw ('psdt' ,   1 ,       Ndata )
          call showw ('irreg' ,  1 ,       Ndata )
          call showw ('f' ,      1 ,       Ndata )
          call showw ('h2' ,     1 ,       Lenh2)
          call showw ('dc' ,     1 ,       Mdc )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       iart = 0 
       iars = 0 
       iarn = 0 
catch- call rpar 
       rlim = rpar ('missing')
       iguess  =  iguess + 1 
       alpha  =  0.01d0 
       beta  =  0.01d0 
       gamma  =  0.1d0   
c 
c      preset parameters 
       zersum  =  1.d0 
       order  =  2   
       sorder  =  1 
       wtrd  =  1.d0  
       period  =  Lpe 
       fixd  =   - 1 
       ap = period 
       iprd = 2 
       if( period.eq.1)iprd = 1  
       lftrn  =  order + iart   
       lfsea  =  ( sorder + iars ) * period + iarn                     
       idc = lftrn *  iprd + 1 
       idcx  =  lfsea  *  2 + 1   
       if( period .gt. 1 .and. idc .lt. idcx )  idc = idcx         
       if( period .gt. 1 .and. idc .lt. period * 2 - 1) idc = period * 2 - 1     
       nh =  lfsea + 1  
       n2 = 1 
cc       if( year .ne. 0) n2 = 8   
  605  format( ' ia is too small' )
  200  continue 
       sy  =  0.d0 
       iq = 0 
       do 2468 i = 1 , Ndata 
          ytem  =  Y ( i )
          if( rlim .le. 0.d0) goto 4681 
          if( ytem .ge. rlim ) goto 2468 
 4681     iq  =  iq + 1                           
          sy  =  sy + ytem 
          if( iq .ge. period ) goto 4680 
 2468  continue   
 4680  continue 
       ytem  =  sy  /  ap 
       do 8  i = 1 , lftrn 
          ftrn ( i )  =  ytem 
    8  continue 
       if( lfsea .ne. 0) then   
          do 9  i = 1 , lfsea 
             fsea ( i )  =  0.d0 
    9     continue 
       end if 
       icase  =  iguess * 100 + Nch 
       iphase  =  0 
       ratio  =  2.d0 
       rigid  =  1.d0 
       ichk = 0 
       if( myid .eq. 0) write(6,*) 'icase  = ' ,  icase 
 1445  rigidt  =  rigid 
       if( Iauto .eq. 0 .and. ichk .ne. 0 ) then 
catch-    call jfrex 
          j = j 
          j  =  jfrex ('init' , 1)
          j  =  jfrex ('g' , 0)
          j  =  jfrex ('c' , 1)
          if( mYID .eq. 0) then
             write(6,'(1X,''present RIGID ='',F7.3)') rigidt
          end if 
          call keympi ('R','RIGID: g?c?' , 1 , ckey , rigid , ix )
          if( ckey .ne. 'c') rigid = 0.d0  
       else 
          rigid  =   - 1 
       end if 
       ichk = 1 
       if( rigid .eq.  - 1) then 
          rigid  =  rigidt * ratio 
          if( iphase .eq. 0) rigid  =  1.d0 
       end if 
       if( rigid .eq. 0) then 
          rigid  =  rigidt 
          goto 1444 
c         ========= 
       end if      
c      ------      
#ifdef AUTHOR 
       call snum ('rigid' , icase , rigid , '( f10.2)')
#endif 
       do 1201 i = 1 , Lenh2 
          h2 ( i ) = 0.d0 
 1201  continue 
       do 1202 i = 1 , Lenh 
          h ( i ) = 0.d0 
 1202  continue  
       do 1203 i = 1 , Mdc 
          dc ( i ) = 0.d0 
 1203  continue 
       zer = zersum / dsqrt ( ap ) * rigid   
       smth  =  1.d0 / rigid 
       smth2 = 1.d0 
       n = Ndata 
       call subsea (
     i Y , rlim , fsea , ftrn , fixd , n , idc , nh , n2 , 
     o dmin , abic , Season , Trend , irreg , psdt , psds , 
     w dc , h , f , h2)
       if( Iauto .eq. 0) goto 1445 
       if( iphase .ge. 2) then 
         if( abic .ge. abic0) then 
            iphase  =  iphase + 1 
            rigid  =  rigid0 
            dmin  =  dmin0 
            goto 1444 
c            ========= 
         else 
            rigid0  =  rigid 
            dmin0  =  dmin 
            abic0  =  abic 
         end if     
       end if 
       if( iphase .ge. 8) goto 1444 
c      --------------------------- 
       if( iphase .eq. 1) then 
          if( abic .gt. abic0) then 
              rigid  =  1.d0 
              rigidt  =  1.d0 
              ratio  =  0.5d0 
          else 
              rigid0  =  rigid 
              dmin0  =  dmin 
              abic0  =  abic 
          end if 
          iphase  =  2   
       end if 
       if( iphase .eq. 0) then 
          iphase  =  1 
          rigid0  =  rigid 
          dmin0  =  dmin 
          abic0  =  abic 
       end if              
       goto 1445 
c      ========= 
 1444  continue 
       if( myid .eq. 0 ) write(6,*) 'rigid = ' , rigid 
       if( fixd .le. 0.d0) then 
          fixtem  =  dmin 
          smth  =  1.d0 / rigid * Abuse 
          call subsea (
     i    Y , rlim , fsea , ftrn , fixtem , n , idc , nh , n2 , 
     o    dmin , abic , Season , Trend , irreg , psdt , psds , 
     w    dc , h , f , h2)
       end if 
       avabic = abic 
 1234  continue 
       if( myid .eq. 0) write(6 , 600) avabic 
  600  format(' abic  = ' , f10.2) 
#ifdef AUTHOR 
       call snum ('abic' , icase , avabic , '( f10.2)')             
       call snum ('dmin' , icase , dmin , '( f10.2)')
#endif 
       nnn = 50 
       if( Ndata .lt. nnn ) nnn = Ndata 
       Vtrend  =  0.d0 
       Vseas  =  0.d0 
       do 1122 j = 1 , Ndata 
          Y ( j )  =  irreg ( j ) 
          if( j .gt. 2) Vtrend  =  Vtrend +                  
     *    ( Trend ( j ) - 2.d0 * Trend ( j - 1) + Trend ( j - 2)) *  * 2        
          if( period .ne. 1 .and. j .ge. period ) then              
             sum  =  0.d0  
             do 2121 k = 1 , period 
                sum  =  sum + Season ( j + 1 - k ) 
 2121        continue 
             Vseas  =  Vseas + sum *  * 2                       
          end if 
 1122  continue 
       tem  =  Trend (2) - Trend (1)                       
       Trinit (1)  =  Trend (1) - tem 
       Trinit (2)  =  Trend (1) - 2.d0 * tem 
       Vtrend  =  Vtrend  /  ( Ndata - order )                
       Vseas  =  Vseas  /  ( Ndata - period + 1)               
       if( myid .eq. 0) then 
catch-    call clab 
catch-    call cpar 
catch-    call rpar 
catch-    call ipar 
          ctem = cpar ('unit')
          if( ctem (1:4) .eq. 'year') then 
               item  =  ipar ('date') / 10000 
          else 
              item = 0 
          end if 
          t0  =  item 
          call lgraph (
     i    irreg , nnn , rlim , clab ( Nch ) , 1.d0 , 0.d0 , 0.d0 , 
     i    t0 , rpar ('sampling') , cpar ('unit') , 50 , 1)
          call lgraph (
     i    Trend , nnn , rlim , clab ( Nch ) , 1.d0 , 
     i    0.d0 , 0.d0 , t0 , rpar ('sampling') , cpar ('unit') , 50 , 1)
          if( period .ne. 1)
     *    call lgraph (
     i    Season , nnn , rlim , clab ( Nch ) , 1.d0 , 0.d0 , 0.d0 , 
     i    t0 , rpar ('sampling') , cpar ('unit') , 50 , 1)
       end if 
       goto 9100 
      end  
#endif

checkpoint:          lano =    90/129/sp2.@990422.@152623 ........
contents    13.3  subsea              
c reusable
      subroutine subsea (
     i Ys , Rlim , Fsea , Ftrn , Fixd , N , Idc , Nh , N2 , 
     o Dmin , Abicm , Season , Trend , Irreg , Psdt , Psds , 
     w dc , h , f , h2 )
       implicit  real * 8  ( a-h , o-z ) 
#include "ardock.env"
       integer * 4 period , year  
       common  / ibaysea /  period , iord , isod , ifix 
       common  / rbaysea /  alpha , beta , gamma , zer , smth , smth2 , 
     * dd , wtrd  
       real * 8   Irreg 
       dimension   Fsea (1) ,  Ftrn (1) ,  dc ( Idc , 1) ,  Ys (1) , 
     * h2 ( N2 , 1) ,  
corrected1999.10.28 following 4 lines are corrected by M.I.
     * err (MAXN*2+1) , Psdt (MAXN) , Psds (MAXN) ,                           
     * Season (1) , Trend (1) , Irreg (1) , a (MAXN*2+1) ,     
     * h ( Nh , 1) , f (1)       
       dimension  dtrn (MAXN) , dseas (MAXN)     
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      subsea 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('subsea', io , stio )                  
          call showm2 ('I',
     i    ' Seasonally adjusts given time series.',
     i    ' A simplified version of BAYSEA(Akaike and Ishiguro, 1980)')
          call showr ('I','Ys' ,     Ys ,       1 , 1 , N )    
          call showr ('I','Rlim' ,   Rlim ,     1 , 1 , 1)     
          call showr ('I','Fsea' ,   Fsea ,     1 , 1 , 4)
          call showr ('I','Ftrn' ,   Ftrn ,     1 , 1 , 2)
          call showr ('I','Fixd' ,   Fixd ,     1 , 1 , 1)    
          call showi ('I','N' ,      N ,        1 , 1 , 1)
          call showi ('I','Idc' ,    Idc ,      1 , 1 , 1)    
          call showi ('I','Nh' ,     Nh ,       1 , 1 , 1)    
          call showi ('I','N2' ,     N2 ,       1 , 1 , 1)
          call showr ('O','Dmin' ,   Dmin ,     1 , 1 , 1)     
          call showr ('O','Abicm' ,  Abicm ,    1 , 1 , 1)     
          call showr ('O','Season' , Season ,   1 , 1 , N )
          call showr ('O','Trend' ,  Trend ,    1 , 1 , N )
          call showr ('O','Irreg' ,  Irreg ,    1 , 1 , N )    
          call showr ('O','Psdt' ,   Psdt ,     1 , 1 , N )    
          call showr ('O','Psds' ,   Psds ,     1 , 1 , N )
          call showw ('dc' ,     1 ,        Idc )
          call showw ('h' ,      1 ,        Nh )
          call showw ('f' ,      1 ,        10)     
          call showw ('h2' ,     1 ,        n2)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       nf = 0 
       itrn = 1 
       logt = 0 
       year = 0 
       nday = 1 
       ajacob = 0.d0     
       if( logt .eq. 1) then   
          do 6100 i = 1 , N  
             if( Ys ( i ) .lt. Rlim .or. Rlim .le. 0.d0)
     *       ajacob = ajacob + Ys ( i )
 6100     continue 
          ajacob = ajacob + ajacob   
       end if 
       iflag = 0 
       dmax0  =  1000.d0 
       dmin0  =  1.0d0  
       mode  =  0 
       ro  =  1.41421d0 
       if( itrn .ne. 0) ro  =  dsqrt ( ro ) 
       nd = ( N + nf ) * 2     
       if( period .eq. 1) nd = N + nf 
       n7  =  nday + 6  
       if( year .ne. 0) nd = nd + n7 
       Abicm  =  1.d50  
       alndt0 = 0.d0     
       if( Fixd .gt. 0.d0) then 
          itrn0 = 1 
          dd = Fixd 
       else 
          itrn0  =  30 
          dd = Dmin 
          if( itrn.eq.1) dd = 5.d0  
       end if 
       do 9999  iiii = 1 , itrn0 
c         construction and householder transformation of matrix dc 
          wt = dd * smth 
          if( iiii.eq.1 .and. period .gt. 1) then 
             call setdc (
     i       Fsea , smth2 , zer , Nh , N + nf , 
     o       h , f , M1 ) 
             alndt0 = 0.d0     
             do 2233 i = 1 , m1 
                tem = dabs ( h (1 , i )) 
                alndt0 = alndt0 + dlog ( tem )
 2233        continue                     
          end if 
c         calculation of log ( det ( dc'dc )) * 0.5                           '
          alndtd = ( N + nf ) * dlog ( wt ) + iord * dlog ( alpha ) +
     *    alndt0           
          if( period.ne.1)alndtd = alndtd + ( N + nf ) * dlog ( dd )           
c         construction and householder transformation of matrix dcx 
 4567     continue 
          call setx (
     i    Ys , Rlim , dd , wt , f , Ftrn , h , N , Idc , N2 , Nh , 
     i    N + nf , 
     o    dc , h2 , m1 , icount )
c         least squares computation 
          k = m1 + N2 
          sqe  =  h2 ( N2 , k ) ** 2 
c         abic computation 
          an  =  icount     
          ann  =  icount + nd 
          alndn = 0.d0 
          do 3344 i = 1 , m1 
             tem = dabs ( dc (1 , i ))
             alndn = alndn + dlog ( tem )
 3344     continue 
          if( N2 .ne. 1) then 
             n2m1 = N2 - 1 
             do 3345 i = 1 , n2m1 
                tem = dabs ( h2 ( i , m1 + i ))   
                alndn = alndn + dlog ( tem )
 3345        continue 
          end if 
          alsqe = an * dlog ( sqe / an )  
          abic = alsqe + 2.d0 * ( alndn - alndtd )                           
          if( year .ne. 0 .and. wtrd .le. 0.d0) abic = abic + 
     *    n7 * 2.d0  
          abic = abic + ajacob 
          if( myid .eq. 0) write( 6 , 3 )    dd ,  abic 
c         minimum abic procedure 
          if( abic. lt. Abicm .and. Abicm - abic .ge. 0.0001d0) then 
             Abicm  =  abic   
             Dmin  =  dd 
             dd = ro * dd 
             if( iiii .eq. 2) mode  =  1 
             goto 2345 
          end if 
          if( mode .eq. 1) goto 6000   
c         ------------------------- 
 9001     mode  =  1 
          ro  =  1.d0 / ro   
          dd  =  dd * ro * ro  
 2345     continue 
          if( dd .gt. dmax0) then 
             if( mode .eq. 0) goto 9001 
c            -------------------------   
             dd  =  dmax0 
             iflag = 1 
             goto 6000 
c             ========= 
          end if 
c         ------
          if( dd .lt. dmin0) then 
             dd  =  dmin0 
             iflag =  - 1 
             goto 6000 
c             ========= 
          end if 
c      --------- 
 9999  continue 
 6000  continue 
       dd = Dmin 
       wt  =  dd * smth   
       call setx (
     i Ys , Rlim , dd , wt , f , Ftrn , h , N , Idc , N2 , Nh , N + nf , 
     o dc , h2 , m1 , icount )
       ndtem = nd + 1   
       call exsolve (
     i dc , Idc , h2 , N2 , m1 , ndtem , 
     o a , err , sqe )              
       sqe = sqe / ann 
       call decode (
     i a , Ys , err , sqe , Rlim , N , nf , 
     o Season , Trend , Irreg , Psds , Psdt )            
    3  format( 1x  , '    abic (' , d20.10 , '  )  =   ' , f10.2)         
       do 3320 i = 1 , N  
          dtrn ( i ) = Trend ( i ) 
          dseas ( i ) = Season ( i )
 3320  continue 
       if( iord .ne. 0) then   
          do 5321 j = 1 , iord 
             nmj = N - j 
             do 3321 i = 1 , nmj 
                dtrn ( i ) = dtrn ( i + 1) - dtrn ( i )
 3321        continue 
 5321     continue 
      end if 
      if( isod .ne. 0) then   
          do 5324 j = 1 , isod 
             nmj = N - j * period 
             do 3324 i = 1 , nmj 
                dseas ( i ) = dseas ( i + period ) - dseas ( i )
 3324        continue 
 5324     continue 
       end if 
       sstr = 0.d0 
       ssea = 0.d0 
       ssir = 0.d0 
       ssas = 0.d0 
       sas = 0.d0 
       ipm1 = period - 1  
       do 3326 i = 1 , ipm1 
          sas = sas + Season ( i )
 3326  continue 
       do 3400 i = 1 , N  
          if( Rlim .gt. 0.d0 .and. Irreg ( i ) .gt. Rlim ) goto 3400 
          ssir = ssir + Irreg ( i ) ** 2  
 3400  continue 
       nmj = N - iord 
       do 3410 i = 1 , nmj 
          sstr = sstr + dtrn ( i ) ** 2 
 3410  continue 
       nmj = N - isod * period 
       do 3420 i = 1 , nmj 
          sas = sas + Season ( i +  ipm1) 
          ssas = ssas + sas ** 2 
          sas = sas - Season ( i )
          ssea = ssea + dseas ( i ) ** 2 
 3420  continue                      
       aprd = period     
       ssas = ssas / aprd                     
       if( myid .eq. 0) write(6 , 606)  Abicm ,  Dmin 
  606  format(1x ,'minimum abic =',f10.2,'  attained at d  = ',d20.10 )
       if( iflag .eq. 1 .and. myid .eq. 0) write(6,600) dmax0           
  600  format(1x ,' ****  d is hitting the upper bound ',d13.5,
     * ' ----- try lower values of order and / or sorder')              
       if( iflag .eq.  - 1 .and. myid .eq. 0) write(6,601) dmin0   
  601  format(1x ,' ****  d is hitting the lower bound ',d13.5,
     * ' ----- try higher values of order and / or sorder')            
       goto 9100 
      end  

checkpoint:           lano =    91/129/sp2.@990422.@152623 ........
contents    13.4  setd                
c reusable
      subroutine setd (
     i C , Ip , Id , 
     o W )                          
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension W ( Ip , 10) ,  ww (10)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      setd 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('setd', io , stio )
          call showm ('I',
     i    ' Composes a difference operator. ')
          call showr ('I','C' ,   C ,    1 , 1 , 1)
          call showi ('I','Ip' ,  Ip ,   1 , 1 , 1)
          call showi ('I','Id' ,  Id ,   1 , 1 , 1)
          call showr ('O','W' ,  W ,    Ip , Ip , idar )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       idar  =  Id 
       idp1  =  Id + 1 
       W (1 , idp1)  =  C  
       ww ( idp1)  =  C   
       if( idar .eq. 0) goto 9100 
c      ------------------------- 
       do 10 j = 1 , idar 
          ww ( j ) = 0.d0 
          do 11 i = 1 , Ip   
             W ( i , j )  =  0.d0 
   11     continue 
   10  continue               
       if( Id .gt. 0) then 
          do 51 j = 1 , Id   
             i  =  idp1 - j - 1 
             do 50 k = 1 , j     
                i  =  i + 1 
                ww ( i )  =  ww ( i ) - ww ( i + 1)
   50        continue 
   51     continue     
       end if 
       do 500 j = 1 , idar 
          W (1 , j )  =  ww ( j ) 
  500  continue 
       goto 9100 
      end  

checkpoint:            lano =    92/129/sp2.@990422.@152623 ........
contents    13.5  setdc                
c reusable
      subroutine setdc (
     i Fseas , Ws , Wz , N1 , N , 
     o H1 , H2 , M1 ) 
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       common  / ibaysea /  ip , id , is , ifix 
       common  / rbaysea /  alpha , beta , gamma , dummy (4) , wtrd 
       dimension  H1 ( N1 , 1) , H2 (1) , Fseas (1) , h3 (100) ,
     * s0 (100) 
       dimension  z0 (50) , si (100) , zi (50) , h4 (50)                   
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      setdc 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('setdc', io , stio )
          call showm2 ('I',
     i    ' Produces the prior part of the',
     i    ' design matrix of the Baysian seasonal adjustment equation.')
          call showr ('I','Fseas' ,  Fseas ,  1 , 1 , 1)
          call showr ('I','Ws' ,  Ws ,     1 , 1 , 1)
          call showr ('I','Wz' ,  Wz ,     1 , 1 , 1)
          call showi ('I','N1' ,  N1 ,     1 , 1 , 1)
          call showi ('I','N' ,   N ,      1 , 1 , 1)
          call showr ('O','H1' ,  H1 ,     N1 , N1 , 1)    
          call showr ('O','H2' ,  H2 ,     1 , 1 , 1)
          call showi ('O','M1' ,  M1 ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       ipis  =  is *  ip   
       ipm1  = ip - 1   
       item  =  ip  * ( is - 1) + 1   
       do 30 i = 1 , ipm1 
          item  =  item + 1 
          zi ( i )  =  Fseas ( item ) * Wz * gamma  
   30  continue           
       sum  =  0.d0 
       item  =  ip 
       do 40 i = 1 , ipm1 
          item  =  item - 1 
          sum  =  sum - zi ( item )   
          zi ( item )  =  sum 
   40  continue 
       call setd (
     i Ws , ip , is , 
     o s0)                           
       if( ipis .gt. 0) then 
          do 20 i = 1 , ipis 
             si ( i )  =  Fseas ( i ) * beta 
   20     continue                       
          call init (
     i    s0 , ipis , 1 , 
     o    si )
       end if 
       do 50 i = 1 , ip   
          z0 ( i ) = Wz 
   50  continue 
       is0  =  ipis + 1 
       iz0  =  ip 
       M1  =  0 
       ipos = 0 
       H2 (1)  =  0.d0   
       do 100 i = 1 , N   
          ipos  =  i 
          n3  =  ipos 
          if( n3 .gt. is0) n3  =  is0 
          item  =  is0 - n3
          do 130 j = 1 , n3  
             item  =  item + 1 
             h3 ( j )  =  s0 ( item )
  130     continue 
          h4 (1)  =  0.d0   
          if( i .le. ipis ) then 
             h4 (1) = si ( i )     
             do 141 j = 1 , n3  
                h3 ( j ) = h3 ( j ) * beta 
  141        continue 
          end if 
          call exhsld (
     i    N1 , 1 , n3 , ipos , 
     a    H1 , H2 , h3 , h4 , M1 )                  
          n3  =  ipos 
          if( n3 .gt. iz0) n3  = iz0 
          item  =  iz0 - n3
          do 150 j = 1 , n3  
             item  =  item + 1 
             h3 ( j )  =  z0 ( item )
  150     continue 
          h4 (1)  =  0.d0   
          if( i .lt. ip ) then 
             h4 (1) = zi ( i )     
             do 161 j = 1 , n3  
                h3 ( j ) = h3 ( j ) * gamma 
  161        continue 
          end if 
          call exhsld (
     i    N1 , 1 , n3 , ipos , 
     a    H1 , H2 , h3 , h4 , M1 )                  
  100  continue 
       goto 9100 
      end  

checkpoint:             lano =    93/129/sp2.@990422.@152623 ........
contents    13.6  setx                
c reusable
      subroutine setx (
     i Y , Rlim , Dd , Wt , F , Ftrn , H , Ndata , N1 , N2 , Nh , N , 
     o H1 , H2 , M1 , Icount )         
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       common  / ibaysea / ip , id , is , ifix 
       common  / rbaysea / alpha , beta , gamma , dummy (4) , wtrd 
       dimension H1 ( N1 , 1) , H2 ( N2 , 1) , Y (1) , h3 (200) ,
     * h4 (50)     
       dimension Ftrn (1) , H ( Nh , 1) , ti (10) , t0 (10) , F (1)    
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      setx 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('setx', io , stio )
          call showm2 ('I',
     i    ' Produces the log likelihood part of the',
     i    ' design matrix of the Baysian seasonal adjustment equation.') 
          call showr ('I','Y' ,     Y ,       1 , 1 , 1)
          call showr ('I','Rlim' ,  Rlim ,    1 , 1 , 1)
          call showr ('I','Dd' ,    Dd ,      1 , 1 , 1)     
          call showr ('I','Wt' ,    Wt ,      1 , 1 , 1)
          call showr ('I','F' ,     F ,       1 , 1 , 1)
          call showr ('I','Ftrn' ,  Ftrn ,    1 , 1 , 1)
          call showr ('I','H' ,     H ,       Nh , Nh , 1)    
          call showi ('I','Ndata' , Ndata ,   1 , 1 , 1)
          call showi ('I','N1' ,    N1 ,      1 , 1 , 1)
          call showi ('I','N2' ,    N2 ,      1 , 1 , 1)
          call showi ('I','Nh' ,    Nh ,      1 , 1 , 1)
          call showi ('I','N     ' ,N ,       1 , 1 , 1)
          call showr ('O','H1' ,    H1 ,      N1 , N1 , 1)    
          call showr ('O','H2' ,    H2 ,      N2 , N2 , 1)
          call showi ('O','M1' ,    M1 ,      1 , 1 , 1)
          call showi ('O','Icount' ,Icount ,  1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( N2 .ne. 1) goto 9100 
c      ----------------------- 
       do 600 i = 1 , N2  
          H2 ( i , N2) = 0.d0 
  600  continue 
       item = 2 
       if( ip.eq.1)item = 1 
       call setd (
     i Wt , item , id , 
     o t0)                         
       do 10 i = 1 , id 
          ti ( i )  =  Ftrn ( i ) * alpha 
   10  continue                       
       call init (
     i t0 , id , item , 
     o ti )   
       Icount = 0 
       M1 = 0 
       id0 = id * item + 1 
       ipos = 0 
       k = 0  
       do 100 i = 1 , N   
          ipos  =  ipos + 1 
          n3  =  ipos 
          if( n3 .gt. id0) n3  =  id0 
          jtem  =  id0 - n3
          do 110 j = 1 , n3  
             jtem  =  jtem + 1 
             h3 ( j )  =  t0 ( jtem )
  110     continue 
          do 120 j = 1 , N2  
             h4 ( j )  =  0.d0 
  120     continue  
          if( i .le. id ) then 
             h4 ( N2) = ti ( i )   
             do 121 j = 1 , n3  
                h3 ( j ) = h3 ( j ) * alpha 
  121        continue                          
          end if 
          call exhsld (
     i    N1 , N2 , n3 , ipos , 
     a    H1 , H2 , h3 , h4 , M1 )                
          n3  =   - 1 
          if( ip .gt. 1) ipos = ipos + 1 
          if( i .le. Ndata ) then 
             if( Y ( i ) .gt. Rlim .and. Rlim .gt. 0.d0) goto 90 
c            -----------------------------------------------        
             Icount = Icount + 1 
             n3  =  item 
             h3 (1)  =  1.d0   
             if( ip.ne.1)h3 (2)  =  1.d0 
             do 30 j = 1 , N2   
                if( j .eq. N2) h4 ( j )  =  Y ( i )   
   30        continue 
          end if 
   90     call exhsld (
     i    N1 , N2 , n3 , ipos , 
     a    H1 , H2 , h3 , h4 , M1 )                
          if( ip .gt. 1 .and. ipos .gt. n1) then   
             k = k + 1 
             j0 = 0 
             do 91 j = 1 , N1   
                if( mod ( j , 2) .ne. 0) then 
                   j0 = j0 + 1 
                   h3 ( j ) = H ( j0 , k ) * Dd 
                else 
                   h3 ( j ) = 0.d0 
                end if 
   91        continue 
             do 92 j = 1 , N2   
                h4 ( j ) = 0.d0 
   92        continue 
             h4 ( N2) = F ( k ) * Dd 
             call exhsld (
     i       N1 , N2 , N1 , ipos , 
     a       H1 , H2 , h3 , h4 , M1 )                
          end if 
  100  continue 
       if( ip .ne. 1) then   
          nmk = N1 
          kp1 = k + 1 
          do 95 k = kp1 , N  
             nmk = nmk - 2 
             j0 = 0 
             do 96 j = 1 , nmk  
                if( mod ( j , 2).ne.0) then 
                   j0 = j0 + 1 
                   h3 ( j ) = H ( j0 , k ) * Dd 
                else 
                   h3 ( j ) = 0.d0 
                end if 
   96        continue 
             do 97 l = 1 , N2   
                h4 ( l ) = 0.d0 
   97        continue 
             h4 ( N2) = F ( k ) * Dd 
             call exhsld (
     i       N1 , N2 , nmk , M1 , 
     a       H1 , H2 , h3 , h4 , M1 )   
   95     continue         
       end if   
       goto 9100 
      end  

checkpoint:              lano =    94/129/sp2.@990422.@152623 ........
contents    13.7  decode              
c reusable
      subroutine decode (
     i A , Y , Err , Sqe , Rlim , Nn , Nf , 
     o Seas0 , Trend0 , Irreg0 , Psds , Psdt )                         
       implicit real * 8 ( a-h , o-z ) 
#include "ardock.env"
       common  / ibaysea /  ip , idummy (2) , ifix 
       real * 8 Irreg0  
       dimension A (1) , Y (1) , Seas0 (1) , Trend0 (1) , Irreg0 (1) , 
corrected1999.10.28 following 1 line is corrected by M.I.
     * Psdt (MAXN) , Psds (MAXN) , Err (MAXN*2+1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ..........................................................
c      decode 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c      This subroutine computes 
c      trend0 ,  Seas0 and Irreg0  =  Y - trend0 - Seas0 
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('decode', io , stio )
          call showm ('I',
     i    ' Interprets the estimated parameter. ')
          call showr ('I','A' ,   A ,        1 , 1 , Nn * 2)
          call showr ('I','Y' ,   Y ,        1 , 1 , Nn )
          call showr ('I','Err' , Err ,      1 , 1 , Nn )
          call showr ('I','Sqe' , Sqe ,      1 , 1 , 1)
          call showr ('I','Rlim' ,Rlim ,     1 , 1 , 1)    
          call showi ('I','Nn' ,  Nn ,       1 , 1 , 1)    
          call showi ('I','Nf' ,  Nf ,       1 , 1 , 1) 
          call showr ('O','Seas0 ' ,   Seas0 ,    1 , 1 , Nn )
          call showr ('O','Trend0' ,   Trend0 ,   1 , 1 , Nn )    
          call showr ('O','Irreg0' ,   Irreg0 ,   1 , 1 , Nn )    
          call showr ('O','Psds' ,     Psds ,     1 , 1 , Nn )
          call showr ('O','Psdt' ,     Psdt ,     1 , 1 , Nn )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       n = Nn + Nf 
       nr  =  2 
       if( ip .eq. 1 )   nr  =  1 
       sd2  =  dsqrt ( Sqe )  *  2.d0 
       do 10 i = 1 , n     
          i1 = nr * ( i - 1) + 1  
          i2 = nr * i 
          Trend0 ( i ) = A ( i1)
          Psdt ( i ) = dsqrt ( Err ( i1)) * sd2   
          if( ip .le. 1) then 
             Seas0 ( i )  =  0.d0 
             Psds ( i ) =  0.d0 
          else 
             Seas0 ( i ) = A ( i2)
             Psds ( i ) = dsqrt ( Err ( i2)) * sd2 
          end if 
          if( Rlim .ne. 0.d0 .and. Y ( i ) .ge. Rlim ) then 
             Irreg0 ( i ) = Y ( i )
          else 
             Irreg0 ( i ) = Y ( i ) - Trend0 ( i ) - Seas0 ( i )
          end if 
   10  continue 
       goto 9100 
      end  

checkpoint:               lano =    95/129/sp2.@990422.@152623 ........
contents    13.8  exhsld              
c reusable
      subroutine exhsld (
     i N1 , N2 , N3 , Ipos , 
     a H1 , H2 , H3 , H4 , M1 )        
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
       dimension  H1 ( N1 , 1) , H2 ( N2 , 1) , H3 ( n3) , H4 ( M1 )           
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
corrected2000.11.21 one line added by M.I.
       data init /1/, eps /0.d0/ 
c      ........................................................
c      exhsld 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('exhsld', io , stio )
          call showm2 ('I',
     i    ' Constructs Householder transformation of a band',
     i    ' structure matrix. ')
          call showi ('I','N1' ,  N1 ,    1 , 1 , 1)
          call showi ('I','N2' ,  N2 ,    1 , 1 , 1)
          call showi ('I','N3' ,  N3 ,    1 , 1 , 1)
          call showi ('I','Ipos', Ipos ,  1 , 1 , 1)
          call showr ('A','H1' ,  H1 ,    N1 , N1 , 10)    
          call showr ('A','H2' ,  H2 ,    N2 , N2 , 10)
          call showr ('A','H3' ,  H3 ,    1 , 1 , N3 )
          call showr ('A','H4' ,  H4 ,    1 , 1 , M1 )
          call showi ('A','M1' ,  M1 ,    1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          do 1 i = 10 , 100 
              epsx  =  10.d0 ** ( - i )
              one  =  1.d0 + epsx 
              if( one .lt. 0.d0) write(6,*) 'one'
              if( one .le. 1.d0) goto 2 
              eps  =  epsx 
    1    continue 
    2    eps =  eps ** 2 
       end if 
       if( Ipos .gt. M1 ) then 
          M1  =  Ipos  
          do 10 j = 1 , N1     
             H1 ( j , M1 )  =  0.d0 
   10     continue 
          do 20 j = 1 , N2 
             H2 ( j , M1 + n2)  =  0.d0 
   20     continue 
       end if 
       if( N3 .lt. 0) goto 9100 
c      ----------------------- 
       m0  =  Ipos - N3 
       do 100 j = 1 , N3  
          if( dabs ( H3 ( j )).lt.eps ) goto 100 
c         ------------------------------- 
          mm  =  m0 + j 
          d  =  H1 (1 , mm ) ** 2 + H3 ( j ) ** 2     
          sqd  =  dsqrt ( d )  
          if( H1 (1 , mm ).gt.0.d0) sqd =  - sqd 
          c  =  d - sqd * H1 (1 , mm )
          d  =  H1 (1 , mm ) - sqd 
          H1 (1 , mm )  =  sqd 
          jp1 = j + 1 
          if( jp1.le.n3) then 
             m  =  1 
             do 50 k = jp1 , n3
                m  =  m + 1 
                if( m .gt. n1) goto 60 
c               ---------------------  
                f  =  d * H1 ( m , mm ) + H3 ( j ) * H3 ( k )
                f  =  f / c     
                H1 ( m , mm )  =  H1 ( m , mm ) - d * f 
                H3 ( k )  =  H3 ( k ) - H3 ( j ) * f  
   50        continue 
   60        continue 
          end if 
          do 8870 k = 1 , N2 
             f  =  d * H2 ( k , mm ) + H3 ( j ) * H4 ( k ) 
             f  =  f / c 
             H2 ( k , mm )  =  H2 ( k , mm ) - d * f 
             H4 ( k )  =  H4 ( k ) - H3 ( j ) * f 
 8870     continue 
  100  continue 
       do 200 j = 1 , N2 
          if( dabs ( H4 ( j )).lt.eps ) goto 200     
c         ------------------------------- 
          mm  =  M1 + j 
          d  =  H2 ( j , mm ) ** 2 + H4 ( j ) ** 2     
          sqd  =  dsqrt ( d ) 
          if( H2 ( j , mm ).gt.0.d0) sqd =  - sqd 
          c  =  d - sqd * H2 ( j , mm )  
          d  =  H2 ( j , mm ) - sqd 
          H2 ( j , mm )  =  sqd 
          if( j .lt. n2) then 
             jp1  =  j + 1 
             do 150 k = jp1 , N2 
                f  =  d * H2 ( k , mm ) + H4 ( j ) * H4 ( k ) 
                f  =  f / c 
                H2 ( k , mm )  =  H2 ( k , mm ) - d * f 
                H4 ( k )  =  H4 ( k ) - H4 ( j ) * f 
  150        continue 
          end if 
  200  continue 
       goto 9100 
      end 

checkpoint:                lano =    96/129/sp2.@990422.@152623 ........
contents    13.9  exsolve             
c reusable
      subroutine exsolve (
     i H1 , N1 , H2 , N2 , M1 , Nans , 
     o A , Err , Sqe )         
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension  H1 ( N1 , 1) ,  H2 ( N2 , 1) ,  A (1) ,  Err (1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      exsolve 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('exsolve', io , stio )
          call showm ('I',
     i    ' Solves least squares problem. ')
          call showr ('I','H1' ,   H1 ,     N1 , N1 , 1)    
          call showi ('I','N1' ,   N1 ,     1 , 1 , 1)
          call showr ('I','H2' ,   H2 ,     N2 , N2 , 1)
          call showi ('I','N2' ,   N2 ,     1 , 1 , 1)
          call showi ('I','M1' ,   M1 ,     1 , 1 , 1)
          call showi ('I','Nans' , Nans ,   1 , 1 , 1)
          call showr ('O','A' ,     A ,      1 , 1 , Nans )
          call showr ('O','Err' ,   Err ,    1 , 1 , Nans )
          call showr ('O','Sqe' ,   Sqe ,    1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       do 30 i = 1 , Nans 
          Err ( i ) = 0.d0 
   30  continue     
       do 100 ler  =  1 ,  Nans   
          k  =  M1 + N2 
          ka  =  Nans   
          jj  =  Nans - 1 
          if( ler.ne.nans )  then 
             Sqe  =  0.d0 
             kam1  =  ka - 1     
             do 40 kka  =  1 ,  kam1 
                A ( kka )  =  0.d0 
   40        continue                  
             A ( ler )  =  1.d0     
          else 
             Sqe  =  H2 ( N2 , k ) ** 2 
             kka  =  ka 
             kk   =  k  
             do 46 j  =  1 ,  jj  
                kk  =  kk - 1   
                kka  =  kka - 1 
                A ( kka )  =  H2 ( N2 , kk )  
   46        continue 
          end if 
          kcopy  =  k   
          do 50 j  =  1 ,  jj 
             ka  =  ka - 1 
             if( A ( ka ).eq.0.d0 )  goto 50                       
c            ----------------------------
             k  =  kcopy - j     
             if( j.lt.n2 )  then 
                A ( ka )  =  A ( ka ) / H2 ( N2 - j , k ) 
                if( ler.lt.nans ) Err ( ka ) = Err ( ka )  + 
     +          A ( ka ) ** 2  
                km1  =  ka - 1 
                if( km1.le.0 )  goto 50 
c               ----------------------- 
                ltem  =  k 
                katem  =  ka 
                aka  =  A ( ka )
                n2mj  =  N2 - j 
                do 10 l  =  1 ,  km1 
                   katem  =  katem - 1   
                   ltem  =  ltem - 1 
                   A ( katem )  =  A ( katem ) - 
     *             aka * H2 ( n2mj , ltem )        
   10           continue 
             else 
                A ( ka )  =  A ( ka ) / H1 (1 , k )   
                if( ler.lt.nans )  Err ( ka ) = Err ( ka ) + 
     +          A ( ka ) ** 2  
                ltem  =  k 
                l  =  ka   
                if( n1.lt.2 )  goto 50 
c               ----------------------
                do 25 i  =  2 ,  N1  
                   l  =  l - 1 
                   ltem  =  ltem - 1 
                   if( l.le.0 )  goto 50 
c                  --------------------- 
                   A ( l )  =  A ( l ) - A ( ka ) * H1 ( i , ltem )     
   25           continue 
             end if 
   50     continue     
  100  continue 
       goto 9100 
      end  

checkpoint:                 lano =    97/129/sp2.@990422.@152623 ........
contents    13.10 init                
c reusable
      subroutine init (
     i Dop , Length , Istep , 
     o W )                      
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       dimension  W (100) ,  ddop (100) ,  Dop (100)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      init 
c      Copyright_OML 1999 M. Ishiguro & H. Akaike 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('init', io , stio )
          call showm2 ('I',
     i    ' Computes initial values of trend componet',
     i    ' or seasonal component. ')
          call showr ('I','Dop' ,    Dop ,     1 , 1 , Length * Istep )
          call showi ('I','Length' , Length ,  1 , 1 , 1)
          call showi ('I','Istep' ,  Istep ,   1 , 1 , 1)
          call showr ('O','W' ,      W ,       1 , 1 , Length )    
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
         goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       j = 1  
       do 1 i = 1 , Length 
          ddop ( i ) = Dop ( j ) 
          j = j + Istep 
    1  continue 
       do 20 j = 1 , Length 
          sum  =  0.d0 
          item  =  0 
          do 10 k = j , Length 
             item = item + 1     
             sum = sum - W ( k ) * ddop ( item )
   10     continue                     
          W ( j ) = sum 
   20  continue 
       goto 9100 
      end  

checkpoint:                  lano =    98/129/sp2.@990422.@152623 ........
contents  14. mpiinit              subpackage
contents    14.1  mpiinit             
c reusable
      subroutine mpiinit 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      mpiinit 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpiinit', io , stio )
          call showm ('I',
     i    ' Initializes MPI')
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       nprocs  =  1 
       myid  =  0 
#ifdef MPI 
       call mpi_init (IERR)
       call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
       call mpi_comm_size (MPI_COMM_WORLD , nprocs , IERR)
#endif 
       if( myid .eq. 0) then 
          write(6 , 60)
   60     format(
     *    1X,'#include "mpisize.param"',
     *     / ,1X,'dimension mpil ( mpiprocs ),mpib ( mpiprocs )',
     *     / ,1X,'common  /commpi/iNFO,mYID,nPROCS,mPI,mPIL,mPIB')
       end if 
       goto 9100 
      end 

checkpoint:                   lano =    99/129/sp2.@990422.@152623 ........
contents    14.2  mpion               
c reusable
      subroutine mpion (
     o Mpiflag )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      mpion 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpion', io , stio )                  
          call showm ('I',
     i    ' Starts parallel computation')
          call showm ('I','info from common area')
          call showi ('I','mPI' ,     mPI ,     1 , 1 , 1)
          call showi ('O','Mpiflag' , Mpiflag , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       Mpiflag = 0 
       if( mPI .ne. 0) goto 9100 
c      ------------------------
       Mpiflag = 1 
       mPI  =  1 
       goto 9100 
      end 

checkpoint:                    lano =   100/129/sp2.@990422.@152623 ........
contents    14.3  mpioff              
c reusable
      subroutine mpioff (
     i Mpiflag )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      mpioff 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpioff', io , stio )                  
          call showm ('I',
     i    ' Finishes parallel computation')
          call showi ('I','Mpiflag' , Mpiflag , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( Mpiflag .eq. 1) mpi = 0 
       goto 9100 
      end 

checkpoint:                     lano =   101/129/sp2.@990422.@152623 ........
contents    14.4  mpison             
c reusable
      subroutine mpison (
     i Jobstart , Jobend , 
     o Istart , Iend )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      mpison 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpison', io , stio )
          call showm ('I',
     i    ' Allocates parallel jobs to processors')
          call showi ('I','Jobstart' , Jobstart , 1 , 1 , 1)
          call showi ('I','Jobend' ,   Jobend   , 1 , 1 , 1)
          call showi ('O','Istart' , Istart   , 1 , 1 , 1)
          call showi ('O','Iend' ,   Iend     , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       njob =  Jobend - Jobstart + 1 
       if( njob .gt. nprocs ) then 
          Istart = njob * myid / nprocs + Jobstart 
          Iend = njob * ( myid + 1) / nprocs + Jobstart - 1 
       else 
          Istart = myid + Jobstart 
          Iend = Istart          
          if( myid .ge. njob ) Iend = Istart - 1 
       end if 
       length = Iend - Istart + 1 
       call mpisres (
     i Istart , length )
       goto 9100 
      end 

checkpoint:                    lano =   102/129/sp2.@990422.@152623 ........
contents    14.5  mpisoff            
c reusable
      subroutine mpisoff (
     i Ix0 , Length , Mpi_kind , 
     o Ix )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      mpisoff 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpisoff', io , stio )                  
          call showm ('I',
     i    ' Gathers results from processors')
          call showi ('I','Length' ,   Length ,   1 , 1 , 1)
          call showi ('I','Mpi_kind' , Mpi_kind , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
#ifdef MPI 
       call mpi_allgatherv ( Ix0 , Length , Mpi_Kind , Ix , mpil , 
     * mpib , Mpi_Kind , MPI_COMM_WORLD , IERROR)
#else 
       Ix = Ix0 
#endif 
       goto 9100 
      end 

checkpoint:                   lano =   103/129/sp2.@990422.@152623 ........
contents    14.6  mpisres            
c reusable
      subroutine mpisres (
     i Istart , Length )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      mpisres 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('mpisres', io , stio )                  
          call showm ('I',
     i    ' Gathers results from processors')
          call showi ('I','Istart' ,   Istart , 1 , 1 , 1)
          call showi ('I','Length' ,   Length , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
#ifdef MPI 
       call mpi_allgather ( Length , 1 , MPI_INTEGER , mpil , 1 , 
     * MPI_INTEGER , MPI_COMM_WORLD , IERROR)
       call mpi_allgather ( Istart - 1 , 1 , MPI_INTEGER , mpib , 1 , 
     * MPI_INTEGER , MPI_COMM_WORLD , IERROR)
#endif 
       goto 9100 
      end 

checkpoint:                  lano =   104/129/sp2.@990422.@152623 ........
contents    14.7  mpistop             
c reusable
      subroutine mpistop ( Ie )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
c      ........................................................
c      mpistop 
c      Stops (parallel) computation.
       if( Ie .eq. 0) return 
       close (91)
       close (99)
       close (IOUNIT)
#ifdef MPI 
       call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
       stop 
      end 

checkpoint:                 lano =   105/129/sp2.@990422.@152623 ........
contents  15. keysave              subpackage
contents    15.1  keysave             
c reusable
      subroutine keysave (
     i Cmd, Key , Icnt , 
     o Cx , Rx , Ix )                   
       implicit real*8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Ix (10) , Rx (10)
       character*(*) Key , Cx 
       character*50 logkey 
       character*1 Cmd , ans 
       character*70 rkey , skey , tline 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/ 
#endif  
#ifdef AUTHOR 
#include "whymper.param"
       character*8  places ( mpoint ) , params ( np , modellim ) 
       character*50 logfile , logeven , logodd 
       common /cwhymper/ logfile , logeven , logodd , places , params 
       common /cauthor/ mAINT , nMITEX  
#endif                    
       data init /1/, init2 /1/, k88 /0/, mbatch /0/ 
       data  m50 /0/, kcheck0 /0/, mwrite0 /0/, memoread /0/ 
c      ........................................................
c      keysave 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       ic = 0 
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          if( now .eq. 1) then
             now = 0 
             m50 = nowm50 
             m5 = nowm5 
             kcheck0 = nowk0 
             mwright0 = nowm0         
          end if       
       end if
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('keysave', io , stio )
          call showm2 ('I',
     i    ' Saves and retraces keyboard inputs.',
     i    ' See Section 6.6 of CSM.')
          call showc ('I','Cmd' ,  Cmd ,    1 , 1 , 1)
          call showc ('I','Key' ,  Key ,    1 , 1 , 1)
          call showi ('I','Icnt' , Icnt ,   1 , 1 , 1)
          call showc ('O','Cx' ,   Cx ,     1 , 1 , 1)      
          call showr ('O','Rx' ,   Rx ,     1 , 1 , ic )      
          call showi ('O','Ix' ,   Ix ,     1 , 1 , ic )      
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          now = 0
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue     
       io = 'O'
       if( mYID .ne. 0) goto 9100
       if( init .eq. 1) then 
          init  =  0 
#ifdef MPI 
          call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
#endif 
          if( myid .ne. 0) iNFO = 0 
          m50 = 5 
          kcheck0 = 0 
          mwrite0 = 0 
       end if 
       ic  =  Icnt 
       if( ic .lt. 0) ic =  - ic 
  888  continue 
       m5 = m50 
       kcheck = kcheck0 
       mwrite = mwrite0 
       if( Key (1:1) .ne. '@') then 
          skey  =  Key 
          if( k88 .ne. 0) goto 9202 
          if( memoread .ne. 1) goto 802 
c         ----------------------------
          goto 9201 
c         ========= 
       end if 
c      ------
       if( init2 .eq. 0) then 
          write(6 , '(''  KS-file is '' , A)') logkey (1:20)
          goto 9100 
c         =========    
       end if 
c      ------
       if( Key (2:2) .ne. '@') then 
          logkey = Key // '.KEY'
#ifdef    AUTHOR 
          if( mAINT .eq. 1 ) then 
             logfile = Key // '.DATA'
             logeven = Key // '.EVEN'
             logodd = Key // '.ODD'
          end if
#endif
       else 
          write(6 , '(''  Give KS-file root:'')')
          call markinp (0 , iNFO )
          read (5 , '(A)') skey 
          if( mbatch .eq. 1) write(6 , '(1X , A)') skey 
          call markinp (1 , iNFO )
          do 9 j = 1 , 50 
             llog  =  j - 1 
             if( skey ( j:j ) .eq. ' ') then 
                logkey = skey (1:llog ) // '.KEY'
#ifdef          AUTHOR
                if( mAINT .eq. 1 ) then 
                   logfile = skey (1:llog ) // '.DATA'
                   logeven = skey (1:llog ) // '.EVEN'
                   logodd = skey (1:llog ) // '.ODD'
                end if 
#endif
                goto 8 
c               ====== 
             end if 
c         --------- 
    9     continue 
       end if 
    8  continue 
       do 11 j = 1 , 50 
          llog  =  j - 1 
          if( logkey ( j:j ) .eq. ' ') goto 12 
   11  continue 
   12  continue 
       write(6 , '(''  KS-file is '' , A)') logkey (1:llog )
       init2  =  0 
       if( logkey (1:12) .ne. '@DEFAULT.KEY') then 
          write(6 , '(2X ,  A)') 
     *    'KEY: s)ave, r)etrace, b)atch-mode or n)ullify' 
          write(6 , 
     *    '(''   option: function'' ,                                       '
     *    / , ''     s   :  to save key inputs'')')                         '
          write(6 , 
     *    '(''     n   :  no save ,  no retrace'' )')
          write(6 , '(2X ,  A , A)') 
     *    '       :  for tutorial help make it S or N , ' , 
     *    ' instead of s or n.' 
          write(6 , 
     *    '(''     r   :  to retrace saved inputs'')')                      
          write(6 , 
     *    '(''     b   :  BACH mode '')')  
          nox = 1 
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
          if( mAINT .eq. 1 )
     *    write(6 , 
     *    '(''     x   :  hidden option for TUTORIAL maker'')')
#endif
          nox = 0  
          call markinp (0 , iNFO )
          read (5 , '(A)') ans 
          if( mbatch .eq. 1) write(6 , '(1X , A)') ans 
          call markinp (1 , iNFO )
       else 
          ans  =  'n'
       end if 
       if( ans .eq. 'N') memoread = 1 
       if( ans .eq. 's' .or. ans .eq. 'S') then 
          write(6 , '(2X , A)') 'SAVE mode'
          m50 = 5 
          kcheck0 = 0 
          mwrite0 = 1 
          if( ans .eq. 'S') memoread = 1 
       end if 
       if( ans .eq. 'r' .or. ans .eq. 'R') then 
          write(6 , '(2X , A)') 'RETRACE mode'
          m50 = 99 
          kcheck0 = 1 
          mbatch = 1
       end if 
       if( ans .eq. 'b' .or. ans .eq. 'B') then 
          write(6 , '(2X , A)') 'BATCH mode'
          m50 = 5 
          kcheck0 = 1 
          mbatch = 1 
          if( ans .eq. 'B') mwrite0 = 1 
       end if 
       if( m50 .eq. 99) mwrite0 = 0 
       if( m50 .eq. 99 .or. mwrite0 .eq. 1) 
     * open (KEEPUNIT , file = logkey )
corrected2000.11.21 ifdef-endif lines are added by M.I.
#ifdef AUTHOR
       if( nox .eq. 0 .and. ans .eq. 'x' ) then 
          memomake  =  1 
          memoread  =  1  
       end if 
#endif
       goto 9100 
c      ========= 
 9201  continue 
       open (TUTUNIT , file = 'TUTORIAL.TXT')
       iq = 0 
  803  read (TUTUNIT , '(A)' , end = 871) tline 
c      ----------------------------
       if( iq .eq. 1) then 
          if( tline (1:5) .eq. 'eeeee') then 
             write(6 , '(''--------------------------'')')
             close (TUTUNIT)
             goto 802 
c             ======== 
          end if 
c         ------
          write(6 , '(2X , A)') tline 
       end if 
c      ------
       if( tline .eq. skey ) then 
          write(6 , '(/ , ''  TUTORIAL INFO'' , / ,                        '
     *    ''--------------------------'')')                                '
          iq = 1 
       end if 
       goto 803
c      ======== 
  871  if( memomake .eq. 1) then 
          write(6 , '(/ , ''  GIVE tutorial info for '' , / ,              '
     *    ''--------------------------'')')                                '
          write(6 , '(1X ,I2,1X,A)') Icnt , skey 
          write(TUTUNIT , '(A)') skey 
          write(6 , '(''--------------------------'')')
          write(6 , '(1X , ''Write memo. End with eeeee'')')
          call markinp (0 , iNFO )
  877     read (5 , '(A)') tline 
          if( mbatch .eq. 1) write(6 , '(1X , A)') tline 
          write(TUTUNIT , '(A)') tline 
          if( tline (1:5) .ne. 'eeeee') goto 877 
c         ------------------------------------
          call markinp (1 , iNFO )
       else
          write(6,*) ' ------------------------'
          write(6,*) ' NO tutorial help. Sorry.'
          write(6,*) ' ------------------------'
       end if 
       close (TUTUNIT)
  802  continue 
       if( skey (1:1) .eq. '/') then 
          write(6 , '(2X , ''$'' , I2 , A)') ic , skey 
       else 
          write(6 , '(2X , A)') skey 
       end if 
 9202  continue 
       k88  =  0 
       if( kcheck .eq. 1) then 
          call markinp (0 , iNFO )
          read ( m5 , '(A)' , err = 88) rkey 
          if( mbatch .eq. 1) write(6 , '(1X , A)') rkey 
          call markinp (1 , iNFO )
          if( rkey (1:5) .eq. '=====') then
             m50 = 5  
             m5 = 5 
             kcheck0 = 0 
             mwrite0 = 0 
             write(6,*) 'end of retrace' 
          else
             if( rkey (1:5) .eq. '-----') then
                read ( m5 , '(A)' , err = 88) rkey 
                read ( m5 , '(A)' , err = 88) rkey 
                write(6 , '(2X , ''Input!:'' , A)') skey 
                now = 1 
                nowm50 = m50
                nowm5 = m5
                nowk0 = kcheck0
                nowm0 = mwright0        
                m50 = 5  
                m5 = 5 
                kcheck0 = 0 
                mwrite0 = 0 
             else
                if( rkey .ne. skey ) then
                   write(6 , '(2X , ''Check!:'' , A)') skey 
                end if
             end if
          end if
       end if 
       if( mwrite .eq. 1) write(KEEPUNIT , '(A)') skey 
       if( Cmd .eq. 'R' ) then
          call markinp (0 , iNFO )
corrected2000.01.20 corrections are made by M.I.
#ifdef OLD
          read ( m5 ,  * ) Cx , ( Rx ( j ) , j = 1 , 
     *    jfrex ( Cx ,  - 1))
#else
          read ( m5 ,'(A,10F10.0)' ) Cx , ( Rx ( j ) , j = 1 , 
     *    jfrex ( Cx ,  - 1))
#endif
          j2 = jfrex ( Cx ,  - 1)
          if( mbatch .eq. 1) write(6,*) Cx , ( Rx ( j ) , j = 1 , j2 )
          call markinp (1 , iNFO )
          if( mwrite .eq. 1) write(KEEPUNIT ,*)  
     *    Cx , ( Rx ( i ) , i = 1 , j2 )
          goto 9100 
       end if
       if( Cmd .eq. 'I' ) then
          call markinp (0 , iNFO )
corrected2000.01.20 corrections are made by M.I.
#ifdef OLD
          read ( m5 ,  * ) Cx , ( Ix ( j ) , j = 1 , 
     *    jfrex ( Cx ,  - 1))
#else
          read ( m5 , '(A,10I3)' ) Cx , ( Ix ( j ) , j = 1 , 
     *    jfrex ( Cx ,  - 1) ) 
#endif
          j2 = jfrex ( Cx ,  - 1)
          if( mbatch .eq. 1) write(6,*) Cx , ( Ix ( j ) , j = 1 , j2 )
          call markinp (1 , iNFO )
          if( mwrite .eq. 1) write(KEEPUNIT ,'(1X,A,1X,5I10)') 
     *    Cx , ( Ix ( i ) , i = 1 , j2 )
          goto 9100 
       end if
       if( Cmd .eq. 'i') then
          call markinp (0 , iNFO )
          read ( m5 ,  * ) ( Ix ( i ) , i = 1 , ic )
          if( mbatch .eq. 1) write(6,*) ( Ix ( i ) , i = 1 , ic )
          call markinp (1 , iNFO )
          if( mwrite .eq. 1) 
     *    write(KEEPUNIT ,  * ) ( Ix ( i ) , i = 1 , ic )
       goto 9100 
c      ========= 
       end if 
c      ------
       if( Cmd .eq. 'r') then
          call markinp (0 , iNFO )
          read ( m5 ,  * ) ( Rx ( i ) , i = 1 , ic )
          if( mbatch .eq. 1) write(6,*) ( Rx ( i ) , i = 1 , ic )
          call markinp (1 , iNFO )
          if( mwrite .eq. 1) write(KEEPUNIT ,  * ) ( Rx ( i ) , i = 1 , ic )
          goto 9100 
c         ========= 
       end if
c      ------ 
       if( Cmd .eq. 'c') then 
          Cx  =  ' '
          call markinp (0 , iNFO )
          read ( m5 , '(A)' , err = 3) Cx 
          if( mbatch .eq. 1) write(6 , '(1X , A)') Cx 
    3     call markinp (1 , iNFO )
          if( mwrite .eq. 1) write(KEEPUNIT , '(A)') Cx 
          goto 9100 
c         ========= 
       end if
c      ------
  88   continue 
       call markinp (1 , iNFO )
       kcheck0 = 0 
       mwrite0 = 1 
       k88  =  1 
       m50 = 5 
       write(6 , '(''  KS-file:'' , A , ''ended. append? ( y/ * )'')') 
     * logkey (1:llog )
       call markinp (0 , iNFO )
       read (5 , '(A)' , err = 89) ans 
       if( mbatch .eq. 1) write(6 , '(1X , A)') ans 
       call markinp (1 , iNFO )
       if( ans .eq. 'y') goto 888 
c      ------------------------- 
   89  continue                                       
       call markinp (1 , iNFO )
       close (KEEPUNIT)
       mwrite0 = 0 
       goto 888 
c      ======== 
      end    


checkpoint:                lano =   106/129/sp2.@990422.@152623 ........
contents    15.2  keympi              
c reusable
      subroutine keympi ( Cmd , Key , Icnt , Cx , Rx , Ix )                 
       implicit real * 8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
corrected2000.01.21 1 line correction by M.I.
c       character*(*) Cmd , Key , Cx  
       character*(*) Key , Cx  
       character*1 Cmd   
       dimension Ix (10) , Rx (10)  
c      ........................................................
c      keympi 
c      keysave for parallel computation.
       call keysave ( Cmd , Key , Icnt , Cx , Rx , Ix )
#ifdef MPI 
       if( Cmd .eq. 'c' .or. Cmd .eq. 'I' .or. Cmd .eq. 'R') then 
          call mpi_bcast ( Cx , 1 , MPI_BYTE , 0 , MPI_COMM_WORLD , 
     *    IERR)
       end if 
       if( Cmd .eq. 'i' .or. CMD .eq. 'I') then 
          call mpi_bcast ( Ix , Icnt , MPI_INTEGER , 0 , 
     *    MPI_COMM_WORLD , IERR)
       end if 
       if( Cmd .eq. 'r' .or. Cmd .eq. 'R') then 
          call mpi_bcast ( Rx ,  Icnt , MPI_DOUBLE_PRECISION , 0 , 
     *    MPI_COMM_WORLD , IERR)
       end if 
#endif 
       return 
      end 

checkpoint:               lano =   107/129/sp2.@990422.@152623 ........
contents    15.3  markinp             
c reusable
      subroutine markinp ( Inout , INFO )
c      ........................................................
c      markinp 
c      Marks keyboard inputs.
       if( INFO .eq. 0) return 
       if( Inout .eq. 0) then 
          write(6,*) '<<<'
       else 
          write(6,*) '>>>'
       end if 
       return 
      end 

checkpoint:              lano =   108/129/sp2.@990422.@152623 ........
contents    15.4  jfrex               
c reusable
      function jfrex ( Cx , Icnt )
       character*(*) Cx 
       character*100 c 
       dimension list (52 , 5)
       character*52 alph 
       data list /260*0/ 
       data alph/'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
c      ........................................................
c      jfrex 
c      Controls keyboard reading.
       c  =  Cx 
       if( c (1:4) .eq. 'init') then 
          do 3 i = 1 , 52 
             list ( i , Icnt ) = 0 
 3        continue 
          icnt0 = Icnt 
          return 
c         ====== 
       end if 
c      ------
       if( c (2:2) .ne. ' ') then 
          jfrex  =  0 
          return 
c         ====== 
       end if 
c      ------
       do 1 k = 1 , 52 
          if( alph ( k:k ) .eq. c (1:1)) then 
              kk = k 
              goto 2 
c             ====== 
          end if 
    1  continue 
       jfrex  =  0 
       return 
c      ====== 
    2  continue 
       if( Icnt .lt. 0) then 
          jfrex  =  list ( kk ,  - Icnt )
       else 
          list ( kk , icnt0) = Icnt 
          jfrex  =  Icnt 
       end if 
       return 
      end 

checkpoint:             lano =   109/129/sp2.@990422.@152623 ........
contents  16. areachk              subpackage                                  
contents    16.1  areachk             
c reusable
      subroutine areachk (
     i Routine , Key , Limit , Length , Icnt ,
     o Ierr )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       character*(*) Key , Routine 
c      ........................................................
c      areachk 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('areachk', io , stio )                  
          call showm ('I',
     i    ' Checks work area size.')
          call showc ('I','Routine' ,   Routine ,   1 , 1 , 1)     
          call showc ('I','Key' ,       Key ,       1 , 1 , 1)     
          call showi ('I','Length' ,    Length ,    1 , 1 , 1)
          call showi ('I','Limit' ,     Limit ,     1 , 1 , 1)
          call showi ('I','Icnt' ,      Icnt  ,     1 , 1 , 1)
          call showi ('O','Ierr' ,      Ierr  ,     1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9199  continue 
       write(6,
     * '(1x,a,'':'',a,''( = '',i10,'') is too small, in node '',i2)')
     * Routine , Key , Limit , myid 
       write(6,'(1x,'' It should be at least '',                        '
     * i5,'' in node '',i2)') Length , myid                               '
 9198  continue
       Ierr = 1 
       call mpistop ( Icnt )
       goto 9100 
c      ========= 
 9200  continue 
       io = 'O'
       Ierr = 0 
       if( Key .eq. '{' .and. limflag .eq. 1) then
          limflag = 0
          goto 9198 
       end if
       if( Length .gt. Limit ) goto 9199 
       goto 9100 
      end 

checkpoint:            lano =   110/129/sp2.@990422.@152623 ........
contents    16.2  iw                  
c reusable
      function iw (
     i Key , Length )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       character*(*) Key 
       data is  / 0 / 
       data maxs  / 0 /  ,  lim  / 0 / 
c      ........................................................
c      Iw       
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('iw', io , stio )
          call showm ('I',
     i    ' Allocates integer type work area in iWK.')
          call showc ('I','Key' ,    Key      , 1 , 1 , 1)
          call showi ('I','Length' , Length   , 1 , 1 , 1)
          call showi ('O','Iw' ,     Iw       , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       Iw = nw     
       return 
c      ====== 
 9199  continue 
       write(6,'(1x,a,''('',i7,'') is too large, in node '' , i2)')
     * Key , Length , myid 
       write(6,'(1x,''work area should be at least '',                       '
     * i9,'' in node '',i2)') is + length,myid                               '
       limflag = 1
       goto 9100
c      ========= 
 9200  continue 
       io = 'O'
       if( Key .eq. '}') then 
          is = Length 
          nw = maxs 
          call mpistop ( limflag )
          goto 9100 
c         ========= 
       end if 
c      ------
       if( Key .eq. '<limit>') then 
          nw = lim 
          goto 9100 
c         ========= 
       end if 
c      ------
       if( Key .eq. '{') then 
          if( Length .gt. 0) lim  =  Length 
          nw  =  is 
          limflag = 0 
          goto 9100 
c         ========= 
       end if 
c      ------
       if( is + Length .gt. lim ) goto 9199 
c      ----------------------------------
       nw = is + 1 
       is = is + Length 
       if( is .gt. maxs ) maxs  =  is 
       goto 9100 
      end 

checkpoint:           lano =   111/129/sp2.@990422.@152623 ........
contents    16.3  nw                  
c reusable
      function nw (
     i Key , Length )
#include "ardock.env"
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       character*(*) Key 
       data is  / 0 / 
       data maxs  / 0 /  ,  lim  / 0 / 
c      ........................................................
c      nw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9       
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('nw', io , stio )
          call showm ('I',
     i    ' Allocates real type work area in wK.')
          call showc ('I','Key' ,    Key      , 1 , 1 , 1)
          call showi ('I','Length' , Length   , 1 , 1 , 1)
          call showi ('O','Nw' ,     Nw       , 1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9199  continue 
       write(6,'(1x,a,''('',i7,'') is too large, in node '' , i2)')
     * Key , Length , myid 
       write(6,'(1x,''work area should be at least '',                       '
     * i9,'' in node '',i2)') is + Length , myid                             '
       limflag = 1
       goto 9100
c      ========= 
 9200  continue 
       io = 'O'
       if( Key .eq. '}') then 
          is = Length 
          Nw = maxs 
          call mpistop ( limflag )
          goto 9100 
c         ========= 
       end if 
c      ------
       if( Key .eq. '<limit>') then 
          Nw = lim 
          goto 9100 
c         ========= 
       end if 
c      ------
       if( Key .eq. '{') then 
          if( Length .gt. 0) lim  =  Length 
          Nw  =  is 
          limflag = 0
          goto 9100 
c         ========= 
       end if 
c      ------
       if( is + Length .gt. lim ) goto 9199 
c      ----------------------------------
       Nw = is + 1 
       is = is + Length 
       if( is .gt. maxs ) maxs  =  is 
       goto 9100 
      end 

#ifdef MODIFIER
checkpoint:          lano =   112/129/sp2.@990422.@152623 ........
contents  17. selfcom              subpackage
contents    17.1  selfcom             
c reusable
      subroutine selfcom ( Key , Io , Stio )
       character*(*) Io , Key , Stio 
       character*1 qIO  
#ifdef AUTHOR
       common /cauthor/ mAINT , nMITEX  
#endif                    
       common /comself/ qIO     
       data init  / 1 /
c      ........................................................
c      version / date          location / memo 
c      version - 0 / 
c                / 1998.12.4    / selflist function 
c                / 1998.12.4    / selflist modified 
c      version - 1 / 1998.12.4 
c   
c      selfcom 
c      Starts  subroutine message printing. 
       if( Io .eq. 'O') then 
          if(  Stio .eq. 'I') then
             qIO = 'o'
          else
             qIO = 'O'
          end if
       else 
          qIO = Io 
       end if
       Stio = Io 
#ifdef AUTHOR 
       if( mAINT .eq. 1 ) then
          if( Io .ne. 'O') call selflist ( Key , 'check')
       end if
#endif
       if( qIO .eq. 'I')  
     *   write(6 , '(                                                       '
     *   /  , '' self comment ----------------------------------'' , 
     *   /  , 1X , A , ''/starts'')') Key                                  '
       if( qIO .eq. 'o')  
     *   write(6 , '(                                                       '
     *   /  , '' self comment ----------------------------------'' , 
     *   /  , 1X , A , ''/ended'')') Key                                    '
       if( qIO .eq. 'O')  
     *   write(6 , '(                                                       '
     *   /  , '' self comment ----------------------------------'' , 
     *   /  , 1X , A , ''/executed'')') Key                                 '
       if( init .eq. 1) then 
#ifdef    AUTHOR 
          if( mAINT .eq. 1 ) then
             call selflist (' ' , 'set')
             call selflist ('selfcom' , 'check')
             call selflist ('selfend' , 'check')
             call selflist ('selflist' , 'check')
             call selflist ('showc' , 'check')
             call selflist ('showr' , 'check')
             call selflist ('showi' , 'check')
             call selflist ('showw' , 'check')
          end if
#endif
          init  =  0 
       end if 
       if( qIO .eq. 'I' .or. qIO .eq. 'i') then 
          call showc ( ' ', '{' , ' '  ,  0,0,0)
          call showr ( ' ', '{' , 0.d0 ,  0,0,0)
          call showi ( ' ', '{' ,    0 ,  0,0,0)
       end if 
       return 
      end 
#endif

#ifdef MODIFIER
checkpoint:         lano =   113/129/sp2.@990422.@152623 ........
contents    17.2  selfend             
c reusable
      subroutine selfend ( Myself , Io , Inisub )
#include "ardock.env"
       character*(*) IO  
       character*1 qIO  
       common /comself/ qIO     
       if( qIO .eq. 'o' .or. qIO .eq. 'O') then 
          call showc (' ','}' , ' '  ,  0,0,0)
          call showr (' ','}' , 0.d0 ,  0,0,0)
          call showi (' ','}' ,    0 ,  0,0,0)
       end if
c      ........................................................
c      selfend 
c      Ends subroutine message printing.
       if( qIO .ne. 'i' ) write(6 , '(                                      '
     *   '' -----------------------------------------------'')')            '
       if( Io .eq. 'O') then
          if( Myself .ge. 1) Inisub = 1 
          if( Myself .lt. 0) then 
             write(6,*) 'stopped because of negative myself.'
             call mpistop (1)
          end if 
       end if 
       return 
      end 
#endif

#ifdef MODIFIER
checkpoint:        lano =   114/129/sp2.@990422.@152623 ........
contents    17.3  showc               
c reusable
      subroutine showc ( Io , Key , X , Mr , Ir , Ic )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*1 qIO 
       common /comself/ qIO     
       character*(*) X ( Mr , 1)
       character*(*) Key , Io 
       character*12 cmemory (1000) , ckeyzzz 
       character*9 ckey 
       character*120 xmemory (1000) , checksum 
       save cmemory , xmemory  
       dimension mstack (100)
       data mem /0/ 
       data mstack /100*0/
       data mem1  / 1 /  ,  mi  / 0 /  ,  mimax  / 0 /  ,  memmax  / 0 / 
c      ........................................................
c      showc 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out character type variable. 
       if( Io .eq. ' ') then 
          if( Key .eq. '{') then 
             if( qIO .eq. 'I' .and. iNFO .ge. 98 ) 
     *       write(6,66) 'showi' , memmax , mimax , mi 
             mi = mi + 1 
             if( mi .gt. mimax ) mimax = mi 
             if( mi .gt. 100) goto 9198 
c            ------------------------- 
             mstack ( mi ) = mem1 
             mem1 = mem + 1 
          end if 
          if( Key .eq. '}') then 
             mem = mem1 - 1 
             mem1 = mstack ( mi )
             mi = mi - 1 
             if( iNFO .ge. 98 ) 
     *       write(6,66) 'showc' , memmax , mimax , mi  
   66        format(1x,A,':memmax/mimax/mi = ',I3,'/',I3,'/',I3)
             if( mi .lt. 0) goto 9198 
c            ----------------------- 
          end if 
          goto 9100 
c         ========= 
       endif 
c      -----
       goto 9200 
c      ========= 
 9101  write(6,*) '  changed!'
 9100  continue 
       return 
c      ====== 
 9198  continue 
       write(6,*) 'showc:mi error.'
       call mpistop (1)
c      =============== 
 9199  continue 
       write(6,*) 'showc:mem exeeded 1000.'
       call mpistop (1)
c      =============== 
 9200  continue 
       ckey = Key 
       if( qIO .eq. 'i' ) goto 9300
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9300
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       irx = Ir 
       if( irx .gt. 3) irx = 3
       icx = Ic 
       if( icx .gt. 5) icx = 5 
       if( Ir .gt. 1) then 
          write(6,'(1X,A,1X,A,'' = '',I5,''*'',I5,'' matrix'')')
     *    Io , ckey , Ir , Ic  
          if( Ic .le. 5) then 
             do 1 i = 1 , irx 
                write(6,'(A11,4 ('','',A11))')
     *          ( X ( i , j ) , j = 1 , icx )
    1        continue 
          else 
             do 2 i = 1 , irx 
                write(6,'(A11,4 ('','',A11),'',...'')') 
     *          ( X ( i , j ) , j = 1 , icx )
    2        continue 
          end if 
          if( Ir .gt. 3) write(6,*) ' ....'
       else 
          if( Ic .le. 5) then 
             write(6,'(1X,A,1X,A,''  = '',A11,4 ('','',A11))') 
     *       Io , ckey , ( X (1 , j ) , j = 1 , icx )
          else 
             write(6,'(1X,A,1X,A,''  = '',A11,4 ('','',A11),'',...'')') 
     *       Io , ckey ,  ( X (1 , j ) , j = 1 , icx )
          end if 
       end if 
 9300  continue
corrected2000.11.21 12 lines here moved below by M.I.
       ckeyzzz = ckey // '###'
       do 31 i = mem1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
corrected2000.11.21 12 lines added by M.I.
             checksum = '!'
             icheck = 1 
             do 21 ii = 1 , Ir  
             do 11 j = 1 , Ic  
                checksum = checksum (1:icheck ) // X ( ii , j )
                do 111 k = icheck + 1 , 120 
                   if( checksum ( k:k ) .eq. ' ') goto 11 
c                  ----------------------------------
                   icheck = k 
  111           continue 
   11        continue 
   21        continue 
             if( xmemory ( i ) .ne. checksum ) then 
                xmemory ( i )  =  checksum 
                goto 9101 
c               ========= 
             end if 
             goto 9100 
c            ========= 
          end if 
   31  continue 
       if( mem .ge. 1000) goto 9199 
c      --------------------------- 
       mem  =  mem + 1 
       if( mem .gt. memmax ) memmax = mem 
       cmemory ( mem ) = ckey // '###'
corrected2000.11.21 one line changed by M.I.
       xmemory ( mem ) = '!' 
       goto 9100 
      end 
#endif

#ifdef MODIFIER
checkpoint:       lano =   115/129/sp2.@990422.@152623 ........
contents    17.4  showi               
c reusable
      subroutine showi ( Io , Key , X , Mr , Ir , Ic )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*1 qIO 
       common /comself/ qIO     
       integer X ( Mr , 1)
       character*(*) Key , Io 
       character*12 cmemory (1000) , ckeyzzz 
       character*9 ckey 
       integer xmemory (1000) , checksum , mstack (100)
       data cmemory /1000*' '/ 
       data xmemory /1000*0/, mstack /100*0/ 
       data mem /0/ 
       data mem1  / 1 /  ,  mi  / 0 /  ,  mimax  / 0 /  ,  memmax  / 0 / 
c      ........................................................
c      showi 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out integer type variable. 
       if( Io .eq. ' ') then 
          if( Key .eq.  '{') then 
             if( qIO .eq. 'I' .and. iNFO .ge. 98 ) 
     *       write(6,66) 'showi' , memmax 
             mi = mi + 1 
             if( mi .gt. mimax ) mimax = mi 
             if( mi .gt. 100) goto 9198 
c            ------------------------- 
             mstack ( mi ) = mem1 
             mem1 = mem + 1 
          end if 
          if( Key .eq.  '}') then 
             mem = mem1 - 1 
             mem1 = mstack ( mi )
             mi = mi - 1 
             if( iNFO .ge. 98 ) 
     *       write(6,66) 'showi' , memmax 
   66        format(1x,A,':memmax          = ',I3)
             if( mi .lt. 0) goto 9198 
c            ----------------------- 
          end if          
          goto 9100 
c         ========= 
       endif 
c      ----- 
       goto 9200 
c      ========= 
 9101  write(6,*) '  changed!'
 9100  continue 
       return 
c      ====== 
 9198  continue 
       write(6,*) 'showi:mi error.'
       call mpistop (1)
c      =============== 
 9199  continue 
       write(6,*) 'showi:mem exeeded 1000.'
       call mpistop (1)
c      =============== 
 9200  continue 
       ckey = Key 
       if( qIO .eq. 'i' ) goto 9300
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9300
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       irx = Ir 
       if( irx .gt. 3) irx = 3
       icx = Ic 
       if( icx .gt. 5) icx = 5 
       if( Ir .gt. 1) then 
          write(6,'(1X,A,1X,A,'' ='',I5,''*'',I5,'' matrix'')') 
     *    Io , ckey , Ir , Ic 
          if( Ic .le. 5) then 
             do 1 i = 1 , irx 
                write(6,'(I11,4 ('','',I11))') 
     *          ( X ( i , j ) , j = 1 , icx )
    1        continue 
          else 
             do 2 i = 1 , irx 
                write(6,'(I11,4 ('','',I11),'',...'')') 
     *          ( X ( i , j ) , j = 1 , icx )
    2        continue 
          end if 
          if( Ir .gt. 3) write(6,*) ' ....'
       else 
          if( Ic .le. 5) then 
             write(6,'(1X,A,1X,A,''  = '',I11,4 ('','',I11))') 
     *       Io , ckey , ( X (1 , j ) , j = 1 , icx )
          else 
             write(6,'(1X,A,1X,A,''  = '',I11,4 ('','',I11),'',...'')') 
     *       Io , ckey ,  ( X (1 , j ) , j = 1 , icx )
          end if 
       end if 
 9300  continue
corrected2000.11.21 6 lines here moved below by M.I.
       ckeyzzz = ckey // '###'
       do 31 i = mem1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
corrected2000.11.21 6 lines added by M.I.
             checksum = 0 
             do 21 ii = 1 , Ir  
             do 11 j = 1 , Ic  
                checksum = checksum + X ( ii , j )
   11        continue 
   21        continue 
             if( xmemory ( i ) .ne. checksum ) then 
                xmemory ( i )  =  checksum 
                goto 9101 
c               ========= 
             end if 
            goto 9100 
c           ========= 
          end if 
   31  continue 
       if( mem .ge. 1000) goto 9199 
c      --------------------------- 
       mem  =  mem + 1 
       if( mem .gt. memmax ) memmax = mem 
       cmemory ( mem ) = ckey // '###'
corrected2000.11.21 one line changed by M.I.
       xmemory ( mem ) = 1234567 
       goto 9100 
      end 
#endif

#ifdef MODIFIER
checkpoint:      lano =   116/129/sp2.@990422.@152623 ........
contents    17.5  showr               
c reusable
      subroutine showr ( Io , Key , X , Mr , Ir , Ic )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
       character*1 qIO 
       common /comself/ qIO     
       dimension X ( Mr , 1)
       character*(*) Key , Io 
       character*12 cmemory (1000) , ckeyzzz 
       character*9 ckey 
       dimension xmemory (1000) , mstack (100)
       data cmemory /1000*' '/ 
       data xmemory /1000*0.d0/, mstack /100*0.d0/ 
       data mem /0/ 
       data mem1  / 1 /  ,  mi  / 0 /  ,  mimax  / 0 /  ,  memmax  / 0 / 
c      .........................................................
c      showr 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out real type variable. 
       if( Io .eq. ' ') then 
          if( Key .eq. '{') then 
             if( qIO .eq. 'I' .and. iNFO .ge. 98 ) 
     *       write(6,66) 'showi' , memmax 
             mi = mi + 1 
             if( mi .gt. mimax ) mimax = mi 
             if( mi .gt. 100) goto 9198 
             mstack ( mi ) = mem1 
             mem1 = mem + 1 
          end if 
          if( Key .eq. '}') then 
             mem = mem1 - 1 
             mem1 = mstack ( mi )
             mi = mi - 1 
             if( iNFO .ge. 98 )
     *       write(6,66) 'showr' , memmax 
   66        format(1x,A,':memmax          = ',I3)
             if( mi .lt. 0) goto 9198 
          end if          
         goto 9100 
       endif 
       goto 9200 
c      ========= 
 9101  write(6,*) '  changed!'
 9100  continue 
       return 
c      ====== 
 9198  continue 
       write(6,*) 'showr:mi error.'
       call mpistop (1)
c      =============== 
 9199  continue 
       write(6,*) 'showr:mem exeeded 1000.'
       call mpistop (1)
c      =============== 
 9200  continue 
       ckey = Key 
       if( qIO .eq. 'i' ) goto 9300
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9300
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       irx = Ir 
       if( irx .gt. 3) irx = 3
       icx = Ic 
       if( icx .gt. 5) icx = 5 
       if( Ir .gt. 1) then 
          write(6,'(1X,A,1X,A,'' ='',I5,''*'',I5,'' matrix'')') 
     *    Io , ckey , Ir , Ic 
          if( Ic .le. 5) then 
             do 1 i = 1 , irx 
                write(6,'(D11.4,4 ('','',D11.4))') 
     *          ( X ( i , j ) , j = 1 , icx )
    1        continue 
          else 
             do 2 i = 1 , irx 
                write(6,'(D11.4,4 ('','',D11.4),'',...'')') 
     *          ( X ( i , j ) , j = 1 , icx )
    2        continue 
          end if 
          if( Ir .gt. 3) write(6,*) ' ....'
       else 
          if( Ic .le. 5) then 
             write(6,'(1X,A,1X,A,''  = '',D11.4,4('','',D11.4))') 
     *       Io , ckey , ( X (1 , j ) , j = 1 , icx )
          else 
             write(6,
     *       '(1X,A,1X,A,''  = '',D11.4,4('','',D11.4),'',...'')') 
     *       Io , ckey ,  ( X (1 , j ) , j = 1 , icx )
          end if 
       end if 
 9300  continue
corrected2000.11.21 6 lines here moved below by M.I.
       ckeyzzz = ckey // '###'
       do 31 i = mem1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
corrected2000.11.21 6 lines added by M.I.
             checksum = 0.d0 
             do 21 ii = 1 , Ir  
             do 11 j = 1 , Ic  
                checksum = checksum + X ( ii , j )
   11        continue 
   21        continue 
             if( xmemory ( i ) .ne. checksum ) then 
                xmemory ( i )  =  checksum 
                goto 9101 
c               ========= 
             end if 
            goto 9100 
c           ========= 
          end if 
   31  continue 
       if( mem .ge. 1000) goto 9199 
c      --------------------------- 
       mem  =  mem + 1 
       if( mem .gt. memmax ) memmax = mem 
       cmemory ( mem ) = ckey // '###'
corrected2000.11.21 one line changed by M.I.
       xmemory ( mem ) =123456.789d0
       goto 9100 
      end 
#endif

#ifdef MODIFIER
checkpoint:     lano =   117/129/sp2.@990422.@152623 ........
contents    17.6  showw               
c reusable
      subroutine showw ( Key , Ir , Ic )
       character*(*) Key 
       character*1 qIO 
       common /comself/ qIO     
       character*9 ckey  
c      ........................................................
c      showw 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out work area size. 
       goto 9200 
c      ========= 
 9100  continue 
       return 
c      ====== 
 9200  continue 
       if( qIO .eq. 'o') goto 9100
       if( qIO .eq. 'i') goto 9100
       ckey = Key 
       write(6,'(1X,''W '',A,'' ='',I5,''*'',I5,'' work area'')') 
     * ckey , Ir , Ic 
       goto 9100 
      end 
#endif

#ifdef MODIFIER
checkpoint:    lano =   118/129/sp2.@990422.@152623 ........
contents    17.7  showm               
c reusable
      subroutine showm ( Io , Key )
       implicit real * 8 ( a-h , o-z )
       character*1 qIO 
       common /comself/ qIO     
       character*(*) Key , Io 
c      ........................................................
c      showm 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out memo. 
       goto 9200 
c      ========= 
 9100  continue 
       return 
c      ====== 
 9200  continue 
       if( qIO .eq. 'i' .and. Io .ne. ' ') goto 9100
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9100
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       write(6,'(1X,A)') Key  
       goto 9100
      end
#endif

#ifdef MODIFIER
checkpoint:   lano =   119/129/sp2.@990422.@152623 ........
contents    17.8  showm2               
c reusable
      subroutine showm2 ( Io , Key1 , Key2 )
       implicit real * 8 ( a-h , o-z )
       character*1 qIO 
       common /comself/ qIO     
       character*(*) Key1 , Key2 , Io 
c      ........................................................
c      showm2 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out two line memo. 
       goto 9200 
c      ========= 
 9100  continue 
       return 
c      ====== 
 9200  continue 
       if( qIO .eq. 'i' .and. Io .ne. ' ') goto 9100
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9100
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       write(6,'(1X,A)') Key1  
       write(6,'(1X,A)') Key2  
       goto 9100
      end
#endif

#ifdef MODIFIER
checkpoint:  lano =   120/129/sp2.@990422.@152623 ........
contents    17.9  showm3               
c reusable
      subroutine showm3 ( Io , Key1 , Key2 , Key3)
       implicit real * 8 ( a-h , o-z )
       character*1 qIO 
       common /comself/ qIO     
       character*(*) Key1 , Key2 , Key3 , Io 
c      ........................................................
c      showm3 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Prints out three line memo. 
       goto 9200 
c      ========= 
 9100  continue 
       return 
c      ====== 
 9200  continue 
       if( qIO .eq. 'i' .and. Io .ne. ' ') goto 9100
       if( qIO .eq. 'I' .and. Io .eq. 'O') goto 9100
       if( qIO .eq. 'o' .and. Io .eq. 'I') goto 9100
       write(6,'(1X,A)') Key1  
       write(6,'(1X,A)') Key2  
       write(6,'(1X,A)') Key3  
       goto 9100
      end
#endif

checkpoint: lano =   121/129/sp2.@990422.@152623 ........
contents    17.10 them                
c reusable
      subroutine them 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
#ifdef AUTHOR 
       common /cauthor/ mAINT , nMITEX  
#endif                    
#ifdef MPI 
       call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
#endif 
c      ........................................................
c      version / date          location / memo 
c      version - 0 / 
c                / 1998.12.4    / modification for selflist option 
c      version - 1 / 1998.12.4 
c   
c      them 
c      Activates self comment function.

       iNFO  =  9 
       if( myid .ne. 0) iNFO = -999 
       if( iNFO .ge. 9) then 
       write(6,'(                                                            '
     *  / ,''ARdock_package'', 
     *  / ,''Copyright_OML 1999 M. Ishiguro, H. Kato and H. Akaike'' 
     * ,/ ,''The source code of this package can be obtained from ''
     * ,/ ,''ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/) of'', 
     *  / ,''the Instituteistical Mathematics '',
     *     ''without any charge.'')')                                        '
       write(6,'(                                                            '
     *     ''On the conditions that terms of the '',
     *     ''OPEN MARKET LICENCE for software'', 
     *  / ,''(ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996), '',
     *     ''are observed'',  
     *  / ,''and that the copyright holder nor the Institute '',
     *     ''of Statistical Mathematics'', 
     *  / ,''take no responsibility on any result from the use, '',
     *     ''programs in the package '', 
     *  / ,''can be used or modified freely. '',
     *     ''On the condition that this note is'', 
     *  / ,''attached as it is, this package can be redistributed.''
     *  ,/ )')                                                               '
       call oml 
       write(6,'(                                                            '
     *  /,'' SELF COMMENT ----------------------------------''
     * ,/,''  Subroutines in this program speak for themselves'',
     *                                            '' in order of ''
     * ,/,''  their appearances, if THEM(!) is(!) called '',
     *                         ''at the beginning of the program,''
     * ,/,''  and the iNFO level is set properly. '',
     *                  ''This function is provided to encourage ''
     * ,/,''  those who would like to make modifications.''
     * ,/,''  If you are not interested in modifying the program,'',
     *                                  '' you can safely remove ''
     * ,/,''  all the portions marked by '',
     *                 ''MODIFIER, without damaging functions of ''
     * ,/,''  subroutines.'')')                                              '
       write(6,'(                                                            '
     *    ''  Equation/Section numbers referd in self comments '',
     *                                            ''are those of ''
     * ,/,''   Ishiguro,M., Kato,H. and Akaike,H. (1999). ''
     * ,/,''    Ardock, an Auto-Regressive model analyzer,''
     * ,/,''    Computer Science Monographs, No.30, ''
     * ,/,''    The Institute of Statistical Mathematics, Tokyo.''
     * ,/,'' -----------------------------------------------'', / )')        '
#ifdef MODIFIER
       write(6,'(''  Present iNFO level is '',I2,''.'')') info 
       write(6,'(''   Make it 0 if you need no COMMENTs.'')')  
#ifdef AUTHOR 
       write(6,'(''   Make it neg. for AUTHOR'')')   
       write(6,'(''   Make it 98 for self comment check:'')')  
       write(6,'(''   Make it -99 or -100 to get SELFLIST:'')')  
       write(6,'(''   Make it -101 for structure analysis'')')  
       write(6,'(''   to debug a specific routine set itself = 8'')')  
       write(6,'(''                              in the routine.'')')  
#endif
       read (5, * ) iNFO 
#else
       iNFO = 0
#endif 
       mAINT = 0
#ifdef AUTHOR 
       if( iNFO .lt. 0 ) then
          mAINT = 1 
          iNFO = - iNFO 
       end if
       if( iNFO .eq. 101 .and. mYID .eq. 0 ) then
          call structur
       end if 
#endif
       end if 
    9  continue 
#ifdef MPI 
       call mpi_bcast ( mAINT , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     * ierr )
#endif  
#ifdef AUTHOR 
       if( mAINT .eq. 1 ) then
          call bug ( 0,0,0,0,'unlock',0,0.d0, message )
       end if
#endif
       return 
      end 

checkpoint:  lano =   122/129/sp2.@990422.@152623 ........
contents    17.11 oml                 
c reusable
      subroutine oml 
      parameter ( l1 = 11,l2 = 8)
      character*70 text ( l1) , text2 ( l2)
      data text  / 
     *'Open Market Licence for software (version:OML-SW-E-1996)',
     *' ',
     *'0. In the following, ''Copyright_OML notice'' means ''the copyrig   '
     *ht',                                                                 '
     *'   notice with a statement saying that the said software is made'
     *,'   public under this Open Market Licence for software''.'
     *,'1. On the condition that ''Copyright_OML notice'' and attached' 
     *,'   statements are copied as they are, all or any portion of the'
     *,'   said software can be copied or redistributed. '
     *,'2. Modification of the software is permitted, provided that'
     *,'   the exact place of the modification, the date and the name'
     *,'   of the modifier are shown conspicuously. ' / 
      data text2  / 
     *'3. It is forbidden to apply for a patent on the software which'
     *,'   utilizes the said software.'
     *,'4. The said software is distributed without any warranty. The',
     *'   copyright holder takes no responsibility for any damage caused  '
     *',                                                                  '
     *'   by the use of the said software.',
     *'5. Any interactively controlled application made utilizing the', 
     *'   said software has to show ''Copyright_OML notice'' and attache  '
     *d',                                                                 '
     *'   statements conspicuously when it is started up.' / 
c      ........................................................
c      oml 
c      Prints out 'Open Market Licence' Terms. 
      do 1 i = 1,l1 
      write(6,'(3X,A)') text ( i )
 1    continue 
      do 2 i = 1,l2 
      write(6,'(3X,A)') text2 ( i )
 2    continue 
      return 
      end 

checkpoint:   lano =   123/129/sp2.@990422.@152623 ........
contents  18. bug                  subpackage
contents    18.1  bug                 
c reusable
      subroutine bug ( Lidy , J , J1 , J2 , Cidt , Iid , Rid , Message )
       implicit real * 8 (a-h,o-z)    
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       common /cmbug/ mess0 , intrct , lc  
       character*(*)  Cidt 
       character*8  cidx , cid  
       character*1  ans ,  clet  
       character*30 version     
       character*80 cbuf , cbugx     
       character*8   clook ,       cletitgo  
       character*8   cmessage ,    clevel   ,  cback    
       character*8   cdummy   ,    cskip   
       character*4  chbug (2), chcom (2), chmap (2), 
     * chdeb (2), chrem (2), choice (2)
       character*4  cb , cc , cm , cd , cr , ch
       character*8  mark8 (2)
       character*10 mark10 (2)
       character*38 mark38 (2) 
       data clook    /'LOOK    '/ , cletitgo /'LETITGO '/ 
       data cmessage /'MESSAGE '/,  clevel   /'LEVEL   '/ , 
     *      cback    /'BACK    '/
       data cdummy   /'DUMMY   '/ , cskip    /'SKIP    '/
       data chbug /'BUG:','bug:'/, chcom /'COM:','com:'/, 
     * chmap /'MAP:','map:'/ 
       data chdeb  /'DEB:','deb:'/, chrem /'MEM:','mem:'/
       data choice /'DEBB','debb'/  
       data iam /1/ 
       data level /0/, map / - 1/ 
       data init /1/ 
       data mark8 / '!!!!!!!!' , 'xxxxxxxx' /    
       data mark10 /'!!!!!!!!!!','xxxxxxxxxx'/   
       data mark38 /'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!', 
     *              'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'/  
       data letitgo /3/, clet /':'/, myid /0/, ndummy /0/, nskip /0/  
c      ................................................................
c      history 
c      version / date           location / memo 
c      proto-1 / 1995.11.26      
c              / 1995.12.6       / level dependent bug!
c      proto-2 / 1995.12.6 
c              / 1995.12.?       / MPI handling 
c      2-MPI   / 1996.1           ISMLIB / 
c              / 1996.4.14               / pre-processing by cpp  
c      3-MPI   / 1998.8.2  bugp ,  bugr ,  bugi routines are added 
c              / 1998.11          implimentation of debug 
c              / 1998.12          implimentation of SKIP / DUMMY command 
c              / 1998.12          extension of LETITGO commnd 
c      proto-3 / 1998.12          lazydog: /  open to isac 
c              / 1998.12.3        level 0 function 
c      4-MPI   / 1999.4.22
c              / 1999.11.2        nowquit 
       version = 'DEBugging Bug, version 4-MPI'
c      bug 
c      Copyright_OML 1999 M. Ishiguro 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Appropriate reference must be made at times of publishing 
c       results obtained using this subroutine. 
c       Read/writes bug.map. See Section \refmy{BUG}.
       cb = chbug ( iam )
       cc = chcom ( iam )
       cm = chmap ( iam )
       cd = chdeb ( iam )
       cr = chrem ( iam )
       ch = choice ( iam )
       lidt  =  Lidy 
       nowquit = 0
       if( lidt .lt. 0) then 
          call debug ( Cidt , 'set' , ie )
          goto 99 
       end if 
       if( level .lt. lidt ) goto 99 
       if( J .lt. J1 .or. J .gt. j2) goto 99 
       if( init .eq. 1) then 

          level  =  1 
          lidt  =  1 
          init  =  0 
          intrct = 0 
          mess0 =  1 
#ifdef    MPI 
          call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
#endif 
          if( myid .eq. 0) then 
             write(6,*) version , iam  
             write(6,*)        
             write(6,*) Cidt,': Bug ? (<Y>es / with <M>ap / <N>o bug )'
             read(5 , '(A)') ans 
             if( ans .eq. 'Y' .or. ans .eq. 'y') map  =  0 
             if( ans .eq. 'M' .or. ans .eq. 'm') map  =  1 
             if( ans .eq. 'm' .or. ans .eq. 'y') intrct = 1 
             if( map .ge. 0) then 
                if( map .eq. 1) then 
                   write(6 , '(1x,A,'' started with a Map'')') ch 
               else 
                  write(6 , '(1x,A,'' started'')') ch 
                  write(6 , '(1x,A, I2 , 1H: , A8)') 
     *                    cc , 0 , clook  
                  write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , 0 , cletitgo ,  - 10  
                  write(6,'('' MEM: 0:bug.map command list'')')
                  write(6,'('' MEM: 0:'',6(1X , A))') clook , 
     *            cletitgo , cmessage , clevel ,  cback ,  'QUIT'  
                  write(6,'('' MEM: 0:'',6(1X , A))') cskip ,  cdummy 
               end if 
            else 
               write(6,'(1x,A,'' nullified at '',A,''.'')') Cidt , ch 
            end if 
         end if 

#ifdef MPI 
         call mpi_bcast ( map , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     *   IERR)
         call mpi_bcast ( intrct , 1 , MPI_INTEGER , 0 , 
     *   MPI_COMM_WORLD , IERR)
#endif 
         if( map .ge. 0) then 
            open (BUGLOG ,  file = 'bug.log')
            if( map .eq. 1) then 
               open (BUGMAP ,  file = 'bug.map')
               level  =  0 
               goto 1732 
            end if 
         else 
            level  =  0 
            mess0 = 0 
         end if 
         if( level .le. 0) goto 99 
 1732    lc = 0 
         mess0 = 1 
      end if 
      cid  =  Cidt 
      lc =  lc + 1 
 1733 continue 
      lid  =  lidt 
      if( lid .gt. map ) then        
            write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,              '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' ,                     '
     *      lc , Iid , Rid    
            write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,                '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' ,                     '
     *      lc , Iid , Rid    
            goto 99 
      end if 
      if( ndummy .gt. 0) then 
            ndummy = ndummy - 1 
            write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,              '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,                ' 
     *      Iid , Rid    
            write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,                '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,                '
     *      Iid , Rid  
            goto 99 
      end if 
 
 596  continue 
      if( lid .le. map ) then        
  877    read(BUGMAP , '(A80)' , end = 999) cbuf 
         if( cbuf (1:1).ne. ' ') then 
            cbugx  =  cbuf (1:4)      
            msdos  =  1 
         else 
            msdos  =  0 
            cbugx  =  cbuf (2:5)      
         end if 
 
         if( cbugx .eq. cr ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2)') itx 
               if( itx .eq.  - 1) itx  =  myid 
               if( itx .eq. myid ) write(6 , '(1H  , A80)') cbuf 
               if( itx .eq. myid ) write(BUGLOG , '(A80)') cbuf 
            else 
               read(BUGMAP , '(5X , I2)') itx 
               if( itx .eq.  - 1) itx  =  myid 
               if( itx .eq. myid ) write(6 , '(A80)') cbuf 
               if( itx .eq. myid ) write(BUGLOG , '(A79)') cbuf (1:79)
            end if 

            goto 877 
         end if 
 
         if( cbugx .eq. cc ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , A8 , I8)') itx , cidx , iidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , A8 , I8)') itx , cidx , iidx 
            end if 
            if( itx .eq.  - 1) itx  =  myid 
            if( itx .ne. myid ) goto 596 
            if( cidx .eq. clook ) then 
               level  =  1 
               write(6 , '(1x,A, I2 , 1H: , A8)') 
     *                    cc , myid , cidx 
               write(BUGLOG , '(A, I2 , 1H: , A8)') 
     *                    cc , myid , cidx 
               goto 596 
            end if 
            if( level .le. 0) goto 596 
            if( cidx (1:4) .eq. 'QUIT') then 
               write(6 , '(1x,A, I2 , 1H: , A8)') cc , myid , cidx 
               write(BUGLOG , '(A, I2 , 1H: , A8)') cc , myid , cidx 
               nowquit = 1 
            end if 
            if( cidx .eq. cletitgo ) then 
               letit0  =  letitgo 
               if( iidx .le. 2) then 
                  clet  =  '!'
               else 
                  clet  =  ':'
               end if 
               letitgo = iidx 
               if( letitgo .eq. letit0) goto 596 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                     cc , myid , cidx , letitgo 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                     cc , myid , cidx , letitgo 
               goto 596 
            end if 
            if( cidx .eq. cskip ) then  
               nskip  =  nskip + iidx 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               goto 596 
            end if 
            if( cidx .eq. cdummy ) then  
               ndummy  =  ndummy + iidx - 1 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,             '
     *         Iid , Rid  
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,             '
     *         D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,             '
     *         Iid , Rid   
               goto 99 
            end if 
            if( cidx .eq. cmessage ) then 
               if( mess0 .eq. iidx ) goto 596 
               mess0 =  iidx        
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , myid , cidx , iidx 
               goto 596 
            end if 
            if( cidx .eq. clevel ) then 
               if( map .gt. iidx .or. level .eq. iidx ) then 
                  write(6,'(1x,A,''level change ignored.'')') cd 
                  goto 596 
               end if 
               level  =  iidx 
               cbugx  =  'MAPLINE'
            end if 
            if( cidx .eq. cback ) then 
               if( level .le. map ) then 
                  write(6,'(1x,A,''level back ignored.'')') cd 
                  goto 596 
               end if 
               level  =  map 
               cbugx  =  'MAPLINE'
            end if 

         end if 
         if( cbugx .eq. cm ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , I2)') itx , iidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , I2)') itx , iidx 
            end if 

            if( itx .eq. myid ) then 
               map  =  iidx 
               if( level .eq. iidx ) goto 596 
               level  =  iidx 
               cbugx  =  'MAPLINE'
            end if 
         end if 

         if( cbugx .eq. 'MAPLINE') then 
            write(6,'(1x,A,2(I2,'':''),'':::::::::::::::::::::::::'',        '
     *      '':::::::::::::::::::::::::::::::::::::::'')') cm,myid,level     '
            write(BUGLOG,'(A,2(I2,'':''),'':::::::::::::::::::::::::'',          '
     *      '':::::::::::::::::::::::::::::::::::::::'')') cm,myid,level     ' 
            goto 596 
         end if 

         if( cbugx .eq. cb ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , I2)') itx , lidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , I2)') itx , lidx 
            end if 

            if( lidx .gt. map .or. itx .ne. myid ) goto 877 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP ,'(4X,2(I2,1X),A8,1X,I4,1X,I10 , 1X , D40.33)'
     *                       , err = 9)  itx , lidx , cidx , lcx , 
     *                       iidx , ridx 
            else 
               read(BUGMAP ,'(5X,2(I2,1X),A8,1X,I4,1X,I10 , 1X , D40.33)'
     *                       , err = 9)  itx , lidx , cidx , lcx ,
     *                       iidx , ridx 
            end if 
            if( nskip .gt. 0) then 
               nskip  =  nskip  - 1 
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,1H.,I4,1H:,I10,1H:,         '
     *         D40.33,1H:)') cd , myid , lidx , cidx , lcx , iidx ,        ' 
     *         ridx   
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,1H.,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cd , myid , lidx , cidx , lcx , iidx ,        '  
     *         ridx 
               goto 877 
            end if 
            call debug ( cidx , 'watch' , ie )
            if( ie .eq. 1) goto 877 
    9       continue 

  597       continue 
            if( level .ge. 1) then 
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,             '
     *         D40.33,1H:)') cb , myid , lid , cid , clet , lc ,            '
     *         Iid , Rid    
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cb , myid , lid , cid , clet , lc ,            '
     *         Iid , Rid    
            else 
               goto 999 
            end if 
            if( nowquit .eq. 1) then 
#ifdef MPI 
               call mpi_abort (MPI_COMM_WORLD , ICODE , IERR)
#endif 
               stop 
            end if
            ichk  =  0 
            if( lidx .ne. lid ) then 
                ichk  =  1        
            end if 
            if( cidx .ne. cid ) then 
                ichkcid  =  1         
                ichk  =  1        
            else 
                ichkcid  =  0 
            end if 
 
            if( iidx .ne. Iid ) then 
                ichkiid  =  1 
                ichk  =  1        
            else 
                ichkiid  =  0 
            end if 
            ichkrid  =  0 
            jchkrid  =  0 
            if( ridx .ne. Rid ) then 
               if( ridx .ne. 0.d0) then 
                  ratio  =  ( ridx - Rid ) / ridx 
               else 
                  ratio  =  1.d0  
               end if  
               if( ratio .lt. 0.d0) ratio  =   - ratio 
               if( ratio .gt. 0.d0) then 
                  if( ratio .ge. 10.d0 ** letitgo ) jchkrid  =  1 
                  ichkrid  =  1 
                  ichk  =  1 
               end if 
            end if 
   98       continue 
            if( ichk .gt. 0) then 
                write(6,'(11H mismatch!!,A,6H!!!!!!,A,4H!!!!,A)')
     *          mark8 ( ichkcid + 1 ), mark10 ( ichkiid + 1 ),
     *          mark38 ( ichkrid + 1 )
                write(6,'(5H OLD:,I2,1H:,I2,A1,A8,A1,I4,A1,I10,A1,            '
     *          D40.33,1H:)') myid , lidx ,                                  '
     *          ':', cidx , ':' , lcx , ':', iidx , ':', ridx     
                if( ichkrid .gt. 0) 
     *          write(6 , '(1x,A , I2 ,                                       '
     *          '': ratio = (new_rid-old_rid)/old_rid :'' , D10.3)')          '
     *          cd , myid , ratio 
                write(6 , '(1x,A , I2  ,                                      '
     *          '':                           letitgo :'' , I10)')            '
     *          cd , myid , letitgo 
                iquit = 0 
                if( letitgo .le. 2 .and. ichkcid .gt. 0) iquit = 1 
                if( letitgo .le. 1 .and. ichkiid .gt. 0) iquit = 1 
                if( letitgo .le. 0 .and. jchkrid .gt. 0) iquit = 1 
                if( iquit .eq. 1) then 
                   write(6 , '(1x,A,I2,'':QUIT on the mismatch'',            '
     *             I3)')         cd , myid                                   '
                   write(6,'(1x,A,I2,5H:QUIT)') cc 
                   write(BUGLOG,'(A,I2,5H:QUIT)') cc 
#ifdef             MPI 
                   call mpi_abort (MPI_COMM_WORLD , ICODE , IERR)
#endif 
                   stop 
                end if  
             end if 
             goto 99 
          end if 
          goto 877 
       end if 
  99   continue 
       Message  =  mess0 
       return 
 999   continue 
       if( level .eq. 0)  goto 99 
       write(6 , '(1x,A, I2 ,                                                '
     *  '': no record. new recording starts.'')') cd , myid                  '
       map  =  0 
       goto 1733
      end 

checkpoint:    lano =   124/129/sp2.@990422.@152623 ........
contents    18.2  sbuggle             
c reusable
      subroutine sbuggle ( Message )
       implicit real * 8 ( a-h , o-z )
       common /cmbug/ mess0 , intrct , lc  
c      ................................................................
c      history 
c      version             date           location 
c      2 - MPI               1996.1         ISMLIB 
c      version - 0           1998.12 
c      sbuggle 
c      Smuggles message into the program.
       Message  =  mess0 
       return 
      end 

#ifdef MODIFIER
checkpoint:     lano =   125/129/sp2.@990422.@152623 ........
contents    18.3  bugnet                
c reusable
      subroutine bugnet ( Message ,
     i Kind , Key , ax , ix , ira , ica , irw0 , icw0 , 
     i irz , icz )
       implicit real*8 (a-h,o-z)
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       common /cmbug/ mess0 , intrct , lc  
       character*(*) Kind , Key
       character*1 ans
       dimension ax ( irz , icz ), ix ( irz , icz )
       dimension ic (2), ir (2), iz (2)
       data irb /0/, icb  /0/, mine /0/, init /1/, myid /0/, nprocs /1/
c      ................................................................
c      bugnet  
c      Shows contents of an array.
       if( init .eq. 1) then
          init = 0
#ifdef    MPI 
          call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
          call mpi_comm_size (MPI_COMM_WORLD , nprocs , IERR)
#endif 
       end if
       if( Message .gt. mess0 ) goto 9100 
       goto 9200
 9100  continue
       return
 9200  continue 
       irw = irw0 
       icw = icw0 
       if( irw .gt. irz ) irw = irz
       if( icw .gt. icz ) icw = icz
       goto 9500
 9300  continue
       ans = 'g'
       if( myid .eq. mine ) then
          ir (1) = irb + ira 
          ir (2) = irb + ira + irw - 1
          ic (1) = icb + ica 
          ic (2) = icb + ica + icw - 1
          write(6,'(1x,A,'' :myid:'',i2,'' message:'',i5)')  
     *    Key , myid , message     
          if( Kind .eq. 'r') then 
             write(6,62) ( j , j = ic (1), ic (2))
          else
             write(6,63) ( j , j = ic (1), ic (2))
          end if
          write(6,64)
          do 100 i = ir (1), ir (2) 
             if( Kind .eq. 'r') then 
                write(6,60) i , ( ax ( i , j ), j = ic (1), ic (2))
   60           format(1x, i5,':',6d12.5)
   62           format(7x, 6i12)
             else
                write(6,61) i , ( ix ( i , j ), j = ic (1), ic (2))
   61           format(1x, i5,':',12i6)
   63           format(7x, 12i6)
             end if
  100     continue
          write(6,64)
   64     format(3x,
     *    '----------------------------------------------------------',
     *    '-------')
       end if
       if( intrct .eq. 0 ) goto 9100
#ifdef MPI 
       call mpi_barrier (MPI_COMM_WORLD , IERR)
#endif 
       if( myid .eq. mine ) write(6,*) 'input q/g/l/r/u/d/w/n/p:'
       if( myid .eq. 0 ) then
          read(5,'(A)') ans
          if(ans .eq. 'q') call mpistop (1)
       end if
#ifdef MPI 
       call mpi_bcast ( ans , 1 , MPI_BYTE , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
       if(ans .eq. 'g') goto 9100
       if(ans .eq. 'n') then
          mine = mine + 1
          if( mine .ge. nprocs ) mine = 0
          goto 9300
       end if
       if(ans .eq. 'p') then
          if( myid .eq. 0 ) then
             write(6,*) 'new processor:'
             read(5,*) irx 
          end if
#ifdef    MPI
          call mpi_bcast ( irx , 1 , MPI_INTEGER , 0 , 
     *    MPI_COMM_WORLD , ierr )
          mine = irx
#endif
          goto 9300
       end if
       if(ans .eq. 'D') then
          irx = irw
          icx = 0
          goto 9400
       end if
       if(ans .eq. 'd') then
          irx = irw/2
          icx = 0
          goto 9400
       end if
       if(ans .eq. 'U') then
          irx = -irw
          icx = 0
          goto 9400
       end if
       if(ans .eq. 'u') then
          irx = -irw/2
          icx = 0
          goto 9400
       end if
       if(ans .eq. 'L') then
          icx = -icw
          irx = 0
          goto 9400
       end if
       if(ans .eq. 'l') then
          icx = -icw/2
          irx = 0
          goto 9400
       end if
       if(ans .eq. 'R') then
          icx = icw
          irx = 0
          goto 9400
       end if
       if(ans .eq. 'r') then
          icx = icw/2
          irx = 0
          goto 9400
       end if
       if(ans .eq. 'w' .and. myid .eq. mine ) then
          if( myid .eq. 0 ) then
             write(6,*) 'ir,ic:'
             read(5,*) iz (1) , iz (2)
          end if
#ifdef    MPI
          call mpi_bcast ( iz , 2 , MPI_INTEGER , 0 , 
     *    MPI_COMM_WORLD , ierr )
#endif
          irb = iz (1) - ira
          icb = iz (2) - ica
          goto 9500
       end if
       if( myid .eq. 0 ) then
          write(6,*) 'irx,icx:'
          read(5,*) iz (1), iz (2)
       end if
#ifdef MPI
       call mpi_bcast ( iz , 2 , MPI_INTEGER , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif
       irx = iz (1)
       icx = iz (2)
 9400  continue
       irb = irb + irx
       icb = icb + icx
 9500  continue
       ir (1) = irb + ira 
       if( ir (1) .lt. 1) then
          ir (1) = 1
          irb = 1 - ira
       end if
       ir (2) = irb + ira + irw - 1
       if( ir (2) .gt. irz ) then
          ir (2) = irz
          irb = irz - ira - irw + 1
          ir (1) = irb + ira 
       end if
       ic (1) = icb + ica 
       if( ic (1) .lt. 1) then
          ic (1) = 1
          icb = 1 - ica
       end if
       ic (2) = icb + ica + icw - 1
       if( ic (2) .gt. icz ) then
          ic (2) = icz
          icb = icz - ica - icw + 1
          ic (1) = icb + ica 
       end if
       goto 9300
      end
#endif

#ifdef MODIFIER
#ifdef MPI
checkpoint:      lano =   126/129/sp2.@990422.@152623 ........
contents    18.4  bughtrap            
c reusable
      subroutine bughtrap ( Key , Id , Cmd , Rkey , Ikey , Ie )
       implicit real * 8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*(*) Key , Cmd 
       dimension rlist ( mpiprocs ) ,  list ( mpiprocs )
c      ................................................................
c      bughtrap 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Watches unexpected discrepancy between processors in parallel
c       computation.
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          write(6,*) 'bughtrap:started'
       end if 
       goto 9200 
c      ========= 
 9100  continue 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          if( myself .ge. 2) inisub = 1 
          write(6,*) 'bughtap:exit'
       end if 
       return 
c      ====== 
 9199  continue 
       write(6,*) 'bughtrap:inconsistent variable / ' ,  Key 
#ifdef MPI 
       call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
       stop 
c      ==== 
 9200  continue 
       Ie = 0 
       ista = 1 
       iend = nprocs 
       call mpion ( mpiflag )
       if( mpiflag .eq. 1) then 
          call mpison (1 , nprocs , ista , iend )
       end if 
       do 1496 jx = ista , iend 
          rlist ( jx )  =  Rkey 
          list ( jx )  =  Ikey 
 1496  continue 
#ifdef MPI 
       call mpioff ( mpiflag )
       if( mpiflag .eq. 1) then 
          len = iend - ista + 1 
          call mpisoff ( rlist ( ista ) , len , MPI_DOUBLE_PRECISION ,
     *    rlist )
          call mpisoff ( list ( ista ) , len , MPI_INTEGER , list )
       end if 
#endif 
       if( myid .eq. 0) then 
          do 1498 j = 1 , nprocs - 1 
          do 1497 i = j + 1 , nprocs 
             if( list ( i ) .ne. list ( j ) .or. 
     *       rlist ( i ) .ne. rlist ( j )) then 
                write(6,'('' BUGHTRAP:'',A,'':'',I2)') Key , Id 
                write(6,'('' rlist:'',5d10.3)') 
     *          ( rlist ( k ) , k = 1 , nprocs )
                write(6,'('' list :'',10I5)') 
     *          ( list ( k ) , k = 1 , nprocs )
                Ie = 1 
                if( Cmd (1:4) .eq. 'trap') then 
                   goto 9199 
                else 
                   goto 9100 
                end if 
             end if 
 1497     continue 
 1498     continue 
       end if 
       goto 9100 
      end 
#endif
#endif

#ifdef MODIFIER
checkpoint:       lano =   127/129/sp2.@990422.@152623 ........
contents    18.5  bugvtrap            
c reusable
      subroutine bugvtrap (  Ckeyx , Id , Cmd , Xin , In , Ie )
       implicit real*8 ( a-h , o-z ) 
#include "ardock.env"
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       character*(*) Ckeyx ,  Cmd 
       character*20 cmemory (100), ckeyzzz 
       character*17 ckey 
       dimension memory (100) , xmemory (100)
       data mem  / 0 / 
c      ................................................................
c      bugvtrap 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Watches unexpected changes of variables. 
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          write(6,*) 'bugvtrap:started'
       end if 
       goto 9200 
c      ========= 
 9100  continue 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          if( myself .ge. 2) inisub = 1 
          write(6,*) 'bugvtrap:exit'
       end if 
       return 
c      ====== 
 9199  continue 
#ifdef MPI 
       call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
       stop 
c      ==== 
 9200  continue 
       ckey = Ckeyx 
       ckeyzzz = ckey // '###'
       Ie = 0 
       do 1 i = 1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
              ii  =  i 
              goto 2 
          end if 
    1  continue 
       if( mem .lt. 100) then 
          mem  =  mem + 1 
          ii = mem 
          cmemory ( ii ) = ckey // '###'
          xmemory ( ii ) = Xin 
          memory ( ii ) = In 
       else 
         write(6,*) 'bugvtrap:mem exeeded 100 in' ,  myid 
         goto 9199 
       end if 
    2  continue 
       if( Id .gt. 0) 
     * write(6 , '(1X , A , I2 , A , A , I2 , D12.5 , I10)') 
     * 'bugvtrap:' , myid , ':' , ckey , Id , xmemory ( ii ) , 
     * memory ( ii )
       if( Xin .ne. xmemory ( ii )) Ie = 1 
       if( In .ne. memory ( ii )) Ie = 1 
       if( Ie .eq. 1) then 
          write(6 , '(1X , A , I2 , A , A , I2 , D12.5 , I10)') 
     *    ' ------>:' , myid , ':' , ckey , Id , Xin , In 
          if(  Cmd (1:4) .eq. 'trap') goto 9199 
          if(  Cmd (1:5) .eq. 'reset') then 
             xmemory ( ii ) = Xin 
             memory ( ii ) = In 
          end if 
       end if 
       goto 9100 
      end 
#endif

checkpoint:        lano =   128/129/sp2.@990422.@152623 ........
contents    18.6  debug               
c reusable
      subroutine debug ( Ckeyx , Cmd , Ie )
       implicit real*8 ( a-h , o-z ) 
#ifdef MODIFIER
#include "ardock.env"
#endif
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       character*(*) Ckeyx ,  Cmd 
       character*20 cmemory (100), ckeyzzz 
       character*17 ckey 
       data cmemory /100*'                    '/
       data inisub /0/
       data mem  / 0 / 
c      ................................................................
c      debug 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Enables bug routine to skip some of bug.map lines.
#ifdef MODIFIER
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          write(6,*) 'DEbug:started'
       end if 
#endif
       goto 9200 
c      ========= 
 9100  continue 
#ifdef MODIFIER
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          if( myself .ge. 2) inisub = 1 
          write(6,*) 'DEbug:exit'
       end if 
#endif
       return 
c      ====== 
 9200  continue 
       ckey = Ckeyx 
       ckeyzzz = ckey // '###'
       Ie = 0 
       do 1 i = 1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
              Ie  =  1 
              goto 9100 
          end if 
    1  continue 
       if( Cmd (1:3) .ne. 'set') goto 9100 
c      --------------------------------- 
       if( mem .lt. 100) then 
          mem  =  mem + 1 
          ii = mem 
       else 
          write(6,*) 'debug:mem exeeded 100 in' ,  myid 
#ifdef    MPI 
          call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
          stop 
       end if 
       cmemory ( ii ) = ckey // '###'
       goto 9100 
      end 

#ifdef MODIFIER
checkpoint:         lano =   129/129/sp2.@990422.@152623 ........
contents    18.7  bugp                
c reusable
      subroutine bugp ( Message , Key )
       implicit real * 8 ( a-h , o-z )
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
       common /cmbug/ mess0 , intrct , lc  
       character*(*) Key 
       character*1 ans 
       data myid  / 0 / 
c      ................................................................
c      bugp  
c      Halts the execution of the program.
#ifdef   MPI 
         call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
#endif 
       write(6,'('' ****  '',A,''  ****  lc = '',I3,'' myid = '',I5)') 
     * Key ,  lc ,  myid 
       if( intrct .eq. 0) return 
       if( Message .le. mess0 .and. myid .eq. 0) then 
          write(6,'(''    Message level  = '',I5,'' g/q'')') 
     *    Message 
          ans  =  'g'
          read(5,'(A)',end = 5) ans 
    5     if( ans .eq. 'q') then 
#ifdef       MPI 
             call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
             stop 
          end if 
       end if  
       return 
      end 
#endif

#ifdef AUTHOR 
#ifdef ARDOCKLINK
checkpoint:          lano =   130/129/sp2.@990422.@152623 ........
contents  19. mswitch              subpackage
contents    19.1  mswitch             
c ardock-specific
      subroutine mswitch (
     o Par , Npx )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
#include "whymper.param"
       character*8 modelname ( modellim )
       common  / dmodel /  modelname 
       common  / cmodel /  mYMODEL , mAXMODEL , mODELLIST ( modellim )
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM ,  kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( MAXPAR )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
#endif  
       data inisub /0/
c      ................................................................
c      mswitch   
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself ) then 
          call selfcom ('mswitch', io , stio )
          call showr ('O','Par' ,  Par ,  1 , 1 , Npx )
          call showi ('O','Npx' ,  Npx ,  1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          write(6,*) 'mYMODEL = ' , mYMODEL 
          write(6,*) 'nSYS    = ' , nSYS 
          if( mYMODEL .ge. 1 .and. mYMODEL .le. mAXMODEL )
     *    write(6,*) modelname ( mYMODEL )
          goto 9200
       end if 
c      ========= 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( inisub .eq. 0) then 
          mYMODEL  =  1 
          mAXMODEL = 3
          modelname (3) = 'lt - adjust'
          modelname (2) = 'm - adjust'
          modelname (1) = 'aim - model'
       end if
       if( mYMODEL .le. 0 .or. mYMODEL .gt. mAXMODEL ) goto 9100 
c      ------------------------------------------------------- 
       if( mYMODEL .eq. 1) then 
          mEAN  =  1 
          nSYS  =  1  
          iNITMART  =  1 
          npy  =  mODELLIST (1)
          call gmarts (
     o    Par , npy )
          Npx  =  npy 
          lAGLIST (1) = lAGOPT 
       end if 
       if( mYMODEL .eq. 2) then 
          mEAN  =  1 
          nSYS  =  kCH  
          if( myid .eq. 0) write(6,*) 'nSYS , mYMODEL  = ' ,  nSYS , 
     *    mYMODEL 
          iNITMART  =  1 
          npy  =  mODELLIST (2)
          call gmarts (
     o    Par , npy )
          if( myid .eq. 0) write(6,*) 'nSYS , mYMODEL  = ' ,  nSYS ,
     *    mYMODEL 
          Npx  =  npy 
          lAGLIST (2) = lAGOPT 
       end if 
       if( mYMODEL .eq. 3) then 
          mEAN  =  2 
          nSYS  =  kCH   
          iNITMART  =  1 
          npy  =  mODELLIST (3)
          call gmarts (
     o    Par , npy )
          lAGLIST (3) = lAGOPT 
          Npx  =  npy 
       end if 
       goto 9100 
      end 
#endif
#endif

#ifdef AUTHOR
#ifdef ARDOCKLINK
checkpoint:           lano =   131/129/sp2.@990422.@152623 ........
contents    19.2  xmodel              
c ardock-specific
      subroutine xmodel (
     i Par , Npx , 
     o El , Lel )
       implicit real * 8 ( a-h , o-z )
#include "ardock.env"
#include "whymper.param"
       character*8 modelname ( modellim )
       common  / dmodel /  modelname 
       common  / cmodel /  mYMODEL , mAXMODEL , mODELLIST ( modellim )
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM ,  kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( MAXPAR )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
#endif  
       data inisub /0/
c      ................................................................
c      xmodel 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('xmodel', io , stio )
          call showr ('I','Par' ,  Par ,   1 , 1 , Npx )    
          call showi ('I','Npx' ,  Npx ,   1 , 1 , 1)
          if( io .ne. 'O') then 
             write(6,*) 'mYMODEL  = ' , mYMODEL 
             if( mYMODEL .ge. 1 .and. mYMODEL .le. mAXMODEL )
     *       write(6,*) modelname ( mYMODEL )
             write(6,*) 'iNITMART = ' , iNITMART 
          end if
          call showr ('O','El  ' ,  El ,     1 , 1 , 1)
          call showi ('O','Lel ' ,  Lel ,    1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( inisub .eq. 0) then 
          mAXMODEL = 3
          modelname (3) = 'lt - adjust'
          modelname (2) = 'm - adjust'
          modelname (1) = 'aim - model'
       end if
       if( Npx .le. 0) goto 9100 
       if( mYMODEL .le. 0 .or. mYMODEL .gt. mAXMODEL ) goto 9100 
c      ------------------------------------------------------- 
       if( mYMODEL .eq. 1) then 
          mEAN = 1 
          nSYS = 1 
          npy  =  mODELLIST (1)
          lAGOPT = lAGLIST (1)
          call marts ( Par , npy , El , Lel )
       end if 
       if( mYMODEL .eq. 2) then 
          mEAN = 1 
          nSYS =  kCH 
          npy  =  mODELLIST (2)
          lAGOPT = lAGLIST (2)
          call marts ( Par , npy , El , Lel )
       end if 
       if( mYMODEL .eq. 3) then 
          mEAN = 2 
          nSYS =  kCH 
          npy  =  mODELLIST (3)
          lAGOPT = lAGLIST (3)
          call marts ( Par , npy , El , Lel )
       end if 
       goto 9100 
      end 
#endif
#endif

#ifdef AUTHOR
checkpoint:            lano =   132/129/sp2.@990422.@152623 ........
contents    19.3  arfitq       
c reusable         
      subroutine arfitq (
     i Cmd , Cyw , 
     i An , Bn , Hh , Kch , Lagmax , Mean , Nx , Mx , Maice , 
     a Indexm ,
     o Aicmin , Parl , Con , Lag , 
     w save , resid , Longindex )
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       character*(*) Cyw ,  Cmd 
       dimension Indexm ( Kch , Kch )
       dimension Hh ( Nx , Mx ) , Parl ( Mx , Kch ) ,
     * save ( Nx ) , resid ( Nx ) ,
     * Longindex ( Mx )          
       dimension a (( MAXLAG + 1) * MAXCH ) , con ( MAXCH , MAXCH ) 
       dimension indextem ( MAXCH ) 
       dimension list (1024) , aicl (1024) , indexopt ( MAXCH )
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data init / 1 /, pi /0.d0/, pi2 /0.d0/
c      ........................................................
c      arfitq 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('arfitq', io , stio )
          call showc ('I','Cmd' ,   Cmd ,    1 , 1 , 1)
          call showc ('I','Cyw' ,   Cyw ,    1 , 1 , 1)
          call showi ('I','Kch' ,   Kch ,    1 , 1 , 1)
          call showi ('I','Lagmax', Lagmax , 1 , 1 , 1)
          call showi ('I','Mean' ,  Mean ,   1 , 1 , 1)
          call showi ('I','Indexm', Indexm , Kch , Kch ,Kch )
          call showi ('I','Nx' ,    Nx ,     1 , 1 , 1)
          call showi ('I','Mx' ,    Mx ,     1 , 1 , 1)
          call showr ('I','Hh ' ,   Hh ,     Nx , Mx , Mx )
          call showr ('O','Aicmin', Aicmin , 1 , 1 , 1)
          call showr ('O','Parl' ,  Parl ,    Mx , Mx , Kch )
          call showi ('O','Lag' ,   Lag ,    1 , 1 , 1)    
          call showr ('O','An' ,    An ,     1 , 1 , 1)    
          call showr ('O','Bn' ,    Bn ,     1 , 1 , 1)    
          call showi ('O','Maice',  Maice ,  1 , 1 , 1)    
          call showw ('a' ,      Mx ,        1)
          call showw ('d' ,      Nx ,        1)
          call showw ('d0' ,     Nx ,        1)
          call showw ('indexv' , Mx ,        1)
          call showw ('Indexm', Mx ,     1)
          call showw ('con',    Kch ,     Kch )
          call selfend ( myself , io , inisub )     
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( init .eq. 1) then 
          init  =  0 
          pi  =  atan2 (0.d0 ,  - 1.d0) 
          pi2 = dlog ( pi * 2.d0)
       end if 
       mfkf = Mean + ( Lagmax + 1) * Kch 
       aic  = 0.d0 
       do 900 kk = 1 , Kch 
          mmkk = Mean + Lagmax * Kch + kk - 1 
          do 901 l = 1 , mfkf 
             save ( l ) = Hh ( l , mmkk + 1)
  901     continue 
          do 200 k = 1 , Kch 
             indexopt ( k ) = 1 
             con ( kk , k ) = 0.d0 
  200     continue 
          if( Cmd .eq. 'mulmar') then 
             sqe  =  Hh ( mmkk + 1 , mmkk + 1) ** 2 
             sqeo = An * sqe 
             aick  =  Bn * ( pi2 + dlog ( sqeo ) + 1) + 
     *       2.d0 * ( mmkk + 1)
             nparo  =  mmkk + 1 
             Maice  =  Lagmax 
             if( mYID .eq. 0)  then
                write(6,'( / ,''maice order search for '',                    '
     *          i2,'' - th variable'')') kk                                   '
                write(6 , '(''  order     AIC   #param'')')
             end if
             do 402 lord = Lagmax - 1 , 0 ,  - 1 
                call indexset (
     i          indexopt , lord , Kch , Lagmax , kk , Mean , 
     o          Longindex , npar , id )
                do 902 l = 1 , mfkf 
                   Hh ( l , mmkk + 1) =  save ( l )   
                   resid ( l ) = 0.d0 
  902           continue 
                resid ( mmkk + 1)  =  Hh ( mmkk + 1 , mmkk + 1) 
                call sssolver (
     i          mmkk , Nx , 0 , Longindex , Hh , 
     o          Parl (1 , kk ) , sqez )
                aicx  =  Bn * ( pi2 + 
     *          dlog ( sqez * An ) + 1) + 2.d0 * npar 
                if( mYID .eq. 0)
     *          write(6,'(2x,i2,f11.2,i6)')  lord, aicx , npar
                if( aicx .le. aick ) then 
                   sqeo  =  sqez * An 
                   aick  =  aicx 
                   Maice =  lord 
                   nparo  =  npar 
                end if 
  402        continue 
             if( mYID .eq. 0)
     *       write(6,'(''   MAICE order = '',i3)')  Maice
          end if 
          kfp2 = 2 ** Kch 
          do 201 k = 1 , kfp2  
             list ( k ) = 0 
  201     continue 
          if( myid .eq. 0) then 
             write(6,'(''effective variable search for '',                  '
     *       i2,'' - th variable'')') kk                                    '
             write(6 , '(''         AIC           #param  Indexv'')')
          end if 
          if( Lag .lt. Maice ) Lag = Maice 
          call indexset (
     i    indexopt , Maice , Kch , Lagmax , kk , Mean , 
     o    Longindex , npar , id )
          do 9003 l = 1 , mfkf 
             Hh ( l , mmkk + 1) =  save ( l ) 
 9003     continue 
          call sssolver (
     i    mmkk , Nx , 1 , Longindex , 
     a    Hh , 
     o    Parl (1 , kk ) , sqez )
          sqeo = An * sqez 
          aick  =  Bn * ( pi2 + dlog ( sqeo ) + 1) + 2.d0 * npar 
          nparo = npar 
          list ( id ) = 1 
          aicl ( id ) = aick 
          do 1903 l = 1 , mfkf 
             resid ( l ) = Hh ( l , mmkk + 1) 
 1903     continue 
          if( Cmd .eq. 'mar') then 
             nparo = npar 
             Parl ( mmkk + 1 , kk ) = dsqrt ( sqeo ) 
             aic  =  aic  + aick 
             goto 900 
c            ========  
          end if  
c         ------
  800     new = 0 
          if( myid .eq. 0)
     *    write(6 , 1801) ' ' , aick , nparo ,
     *    ( Indexm ( kk , kkk ) , kkk = 1 , Kch )
 1801     format( a , f10.2 , 15x , i3 , 3x , 10i1)
  801     format( a , f10.2 , 8x , i3 , 3x , 10i1)
          do 600 it1 = 1 , Kch 
             do 601 it2 = 1 , Kch 
                if( it2 .ne. it1) then 
                   indextem ( it2) = Indexm ( kk , it2) 
                else     
                   indextem ( it2) = 1 - Indexm ( kk , it2)     
                end if 
  601        continue 
             call indexset (
     i       indextem , Maice , Kch , Lagmax , kk , Mean , 
     o       Longindex , npar , id ) 
             if( list ( id ) .eq.  1) then 
                aictem  =  aicl ( id )
                con ( kk , it1)  =  aictem - aick 
             else 
                do 9002 l = 1 , mfkf 
                   Hh ( l , mmkk + 1) =  save ( l ) 
 9002           continue 
                call sssolver (
     i          mmkk , Nx , 1 , Longindex , 
     a          Hh , 
     o          a , sqez )
                aictem  =  Bn  * ( pi2 + dlog ( sqez  *  An ) + 1)  + 
     *          2.d0 *  npar 
                if( myid .eq. 0) 
     *          write(6 , 801) '       :' , aictem ,  npar , 
     *          ( indextem ( kkk ) , kkk = 1 , Kch )
                list ( id )  =  1 
                aicl ( id )  =  aictem 
                new = 1 
                con ( kk , it1)  =  aictem - aick 
                if( aictem .le. aick ) then 
                   aick = aictem 
                   sqeo = sqez * An   
                   nparo = npar 
                   do 903 l = 1 , mfkf 
                      Parl ( l , kk )  =  a ( l ) 
                      resid ( l )  =  Hh ( l , mmkk + 1) 
  903              continue 
                   do 1496 kkk = 1 , Kch 
                      indexopt ( kkk ) = indextem ( kkk ) 
 1496              continue 
                end if   
             end if  
  600     continue 
  606     continue 
          if( new .eq. 1 ) then 
             Parl ( mmkk + 1 , kk ) = dsqrt ( sqeo ) 
             do 1498 kkk = 1 , Kch  
                Indexm ( kk , kkk ) = indexopt ( kkk )
 1498        continue 
          end if     
c         ------
           aic  =  aic  + aick 
          do 904 l = 1 , mfkf  
             Hh ( l , mmkk + 1)  =  resid ( l )
  904     continue 
  900  continue
       Aicmin  =   aic 
       goto 9100 
      end 
#endif

#ifdef AUTHOR
checkpoint:             lano =   133/129/sp2.@990422.@152623 ........
contents    19.4  simdat              
c reusable
      subroutine simdat (
     i N , Id , 
     o Data )                      
       implicit real*8 ( a-h , o-z )
#include "ardock.env"
       dimension  ar (2 , 10 , 10) , Data ( MAXN )
       character*1 ckey 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      ........................................................
c      simdat 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0 )
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('simdat', io , stio )                  
          call showi ('I','N' ,   N ,      1 , 1 , 1)     
          call showi ('I','Id' ,  Id ,     1 , 1 , 1)
          call showr ('O','Data' ,   Data ,   N , N , Id )
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          nw1 = nw ('temporal' , MAXN ) - 1 
          goto 9200
       end if 
c      -------------------------- 
       return 
c      ====== 
 9200  continue 
       io = 'O'
c      memo no.6178 1994.1.27 
       write(6,*) 'simulation model' 
       nfix = N 
       Kch = Id 
       if( Id .eq. 0) then 
          Kch = 2     
          write(6,*) ' exiting pair simulation'               
       end if 
       if( myid .eq. 0) then 
          call keysave 
     *    ('i','random number seed:' , 1 , ckey , rx , ix ) 
          write(6,*) 'random number seed = ' , ix 
          rx  =  rn01 ( ix ) 
       end if 
       if( Id .gt. 0) then 
          do 2496 j = 3 , nfix + 50     
catch-       call rnor 
             sum = rnor (1.d0) + wk ( nw1 + ( j - 2 ) * Id + Id )
             wk ( nw1 + ( j - 1) * Id + 1)  =  1.5d0 * 
     *       wk ( nw1 + ( j - 2) * Id + 1) 
     *       - 0.7d0 * wk ( nw1 + ( j - 3) * Id + 1) + sum 
             wk ( nw1 + ( j - 1) * Id + 2) =  0.9d0 *  
     *       wk ( nw1 + ( j - 2) * Id + 2)
     *       + rnor (2.d0)
             if( Id .gt. 2) then 
                do 111 k = 3 , Id   
                   wk ( nw1 + ( j - 1) * Id + k )  =  
     *             wk ( nw1 + ( j - 2) * Id + k - 1)
     *             + rnor (0.5d0)  
  111           continue 
             end if 
             if( j .gt. 3) goto 2496 
c            ----------------------
             ar (1 , 1 , Id )  =  1.d0 
             ar (1 , 1 , 1)  =  1.5d0 
             ar (2 , 1 , 1)  =   - 0.7d0 
             ar (1 , 2 , 2)  =  0.9d0 
             if( Id .gt. 2) then 
                do 113 k = 3 , Id 
                   ar (1 , k , k - 1)  =  1.d0 
  113           continue 
             end if 
 2496     continue 
       else 
          Id = 2 
          do 3496 j = 3 , nfix + 50     
             wk ( nw1 + ( j - 1) * Id + 1)  =   
     *       0.85d0 * wk ( nw1 + ( j - 2) * Id + 2) 
     *       - 0.49d0 * wk ( nw1 + ( j - 3) * Id + 2) + rnor (1.d0)
             wk ( nw1 + ( j - 1) * Id + 2)  =  1.00d0 * 
     *       wk ( nw1 + ( j - 2) * Id + 1) +  
     *       0.58d0 * wk ( nw1 + ( j - 3) * Id + 1) + rnor (1.d0)
             if( j .gt. 3) goto 3496 
c            ----------------------- 
             ar (1 , 1 , 2)  =  0.85d0 
             ar (2 , 1 , 2)  =   - 0.49d0 
             ar (1 , 2 , 1)  =  1.d0 
             ar (2 , 2 , 1)  =  0.58d0 
 3496     continue 
       end if 
       do 100 i = 1 , nfix 
       do 112 k = 1 , Kch 
          Data (( k - 1) * nfix + i )  =  
     *    wk ( nw1 + ( i + 49) * Kch + k )
  112  continue 
  100  continue 
       Kch = Id 
       ifpec = 2 
       write(6,*) 'coefficient matrices'
       do 581 i = 1 , ifpec 
          write(6,*) 'order' , i              
          do 582 ii = 1 , Kch 
             write(6,'(8f10.4)') ( ar ( i , ii , jj ), jj =1, Kch )
  582     continue 
  581  continue 
       goto 9100 
      end 
#endif


#ifdef AUTHOR
checkpoint:              lano =   134/129/sp2.@990422.@152623 ........
contents    19.5  design              
c ardock-specific
      subroutine design ( Kch , Mask , Nblock , Ib , Look )
       implicit real*8 ( a-h , o-z )     
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       dimension Mask ( Kch , Kch ) , Ib ( Nblock )
       character*1 grp (5) , inp (5) , step (5) , freq (5) , cmask (5)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
       data inp / 5 * 'i' /  ,  step / 5 * 's' /  ,  freq / 5 * 'f' / 
c      ........................................................
c      design 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('design', io , stio )
          call showm ('I','Display design display.')
          call showi ('I','Kch' ,   Kch ,    1 , 1 , 1)
          call showi ('I','Mask' ,  Mask ,   Kch , Kch , Kch )
          call showi ('I','Nblock' ,Nblock , 1 , 1 , 1)
          call showi ('I','Ib' ,    Ib ,     1 , 1 , Nblock )
          call showi ('I','Look' ,  Look ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
          goto 9200
       end if 
c      ------------------------- 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( mYID .ne. 0) goto 9100
       write(6,*) '--------- display-design ---------------------' , 
     * '---------------------------------'
       write(6,*) '                      -------------------     '
       write(6,*) '                     |F_window           |    '
       write(6,*) '    -----------------| power spectrum    |    '
       write(6,*) '   |T_window         | power contribution|    '
       write(6,*) '   |  impulse resp.  | L<---F)band---->H |    '
       write(6,*) '   |  simulation etc.|___________________|    '
       write(6,*) '   |______________________|                   '
       write(6,*) '  -----------------------------------         '
       write(6,*) ' |  C_window      d_AIC              |        '
       do 1 i = 1 , Kch 
          grp ( i ) = ' '
    1  continue 
       do 2 i = 1 , Nblock 
          grp ( ib( i )) = 'G' 
    2  continue 
       write(6 , 1008) ( grp ( i ) , i = 1 , Kch )
       do 1005 j = 1 , Kch 
          do 1006 i = 1 , Kch 
             if( Mask ( j , i ) .eq. 1) then 
                cmask ( i ) = 'm'
             else 
                cmask ( i ) = ' '
             end if 
 1006     continue 
          if( j .eq. Look ) then 
             write(6 , 1007) ( cmask ( i ) , i = 1 , Kch ) 
          else 
             write(6 , 1008) ( cmask ( i ) , i = 1 , Kch ) 
          end if 
 1007     format(1x  , 5x , 'c ' , 5A1)
 1008     format(1x  , 7x , 5A1)
 1005  continue 
       write(6,*)
       write(6 , 1008) ( inp ( i ) , i = 1 , Kch )
       write(6 , 1008) ( step ( i ) , i = 1 , Kch )
       write(6 , 1008) ( freq ( i ) , i = 1 , Kch )
       write(6,*) ' |     n)oise                        |        '
       write(6,*) ' |     r)esidual                     |        '
       write(6,*) ' |     P)wSP            q)uit        |        '
       write(6,*) '  -----------------------------------         '
       write(6,*)
       write(6,*) '--------------------------------------------' , 
     * '---------------------------------'
       goto 9100 
      end 
#endif

#ifdef AUTHOR
#define LISTUNIT 97
checkpoint:               lano =   135/129/sp2.@990422.@152623 ........
contents    19.6  selflist            
c reusable
      subroutine selflist ( Ckeyx , Cmd )
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       character*(*) Ckeyx ,  Cmd 
       character*20 cmemory (500) , ckeyzzz 
       character*17 ckey 
       dimension memory (500)
       data mem  / 0 /, memory /500*0/, cmemory /500*' '/ 
c      ................................................................
c      selflist 
c      Copyright_OML 1999 M. Ishiguro & H. Kato 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       if( iNFO .lt. 99) goto 9100 
       if( Cmd (1:3) .eq. 'set') then 
          iset  =  1 
          goto 9300 
       end if 
       if( iset .eq. 0) goto 9100 
       if( Cmd (1:4) .eq. 'list') goto 9400 
       goto 9200 
c      ========= 
 9100  continue 
       return 
c      ====== 
 9200  continue 
       ckey = Ckeyx 
       ckeyzzz = ckey // '###'
       do 1 i = 1 , mem 
          if( cmemory ( i ) .eq. ckeyzzz ) then 
              if( memory ( i ) .eq. 0) memory ( i )  =  1 
              goto 9100 
          end if 
    1  continue 
       if( mem .lt. 500) then 
          mem  =  mem + 1 
          memory ( mem )  =  2 
          cmemory ( mem ) = ckey // '###'
          goto 9100 
       else 
          write(6,*) 'selflist:mem exeeded 500 in' ,  myid 
          call mpistop (1)
       end if 
 9300  open (LISTUNIT , file = 'selflist.dat')
       mem  =  0 
    2  read (LISTUNIT , '(A)' , end = 3) ckey 
       if( mem .ge. 500) then 
          write(6,*) 'selflist:mem exeeded 500 in' ,  myid 
          call mpistop (1)
       end if 
       mem  =  mem + 1 
       cmemory ( mem ) = ckey // '###'
       memory ( mem ) = 0 
       goto 2 
    3  close (LISTUNIT)
       goto 9100 
 9400  continue 
       write(6,*) 'not used routines'
       open (LISTUNIT , file = 'selflist.new')
       ii  =  0 
       do 4 i = 1 , mem 
          if( memory ( i ) .eq. 0) then 
             ii = ii + 1 
             ckey = cmemory ( i )
             write(6,*) ii , i ,  ckey 
             write(LISTUNIT , '(A)') ckey 
          end if 
    4  continue 
       close (LISTUNIT)
       if( iNFO .le. 99) goto 9100 
       write(6,*) 'not registered routines'
       ii  =  0 
       do 5 i = 1 , mem 
          if( memory ( i ) .eq. 2) then 
             ii  =  ii + 1 
             ckey = cmemory ( i )
             write(6,*) ii , i ,  ckey 
          end if 
    5  continue 
       goto 9100 
      end 
#endif

#ifdef AUTHOR
checkpoint:                lano =   136/129/sp2.@990422.@152623 ........
contents  20. structure            subpackage
contents    20.1  structur           
c reusable
      subroutine structur   
       parameter ( NSUB = 200 ) 
       character*80 buff 
       character*20 name , filen , nlist ( NSUB ) 
       character*1 code , io  
       dimension isort ( NSUB ), irel ( NSUB , NSUB ) 
       dimension irelx ( NSUB , NSUB ) , irely ( NSUB , NSUB ) , 
     * ipack ( NSUB ) , mpack ( NSUB ) ,
     * jpack ( NSUB ), kpack ( NSUB ) , ireach ( NSUB )  
       dimension listcom ( NSUB )
c      ........................................................
c      structure  
c      Copyright_OML 1999 M. Ishiguro  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       write(6,*) 'structure analysis routine'
       io = 'I'
 9100  if( io .eq. 'O') then
          write(6,*) 'end of the analysis'
          call mpistop (1)
          stop
       end if 
       io = 'O'
       llist = 1 
       isort (1) = llist 
       nlist (1) = 'main '
       nums = 1 
       lpack = 1 
       ipack (1) = 1
       mpack (1) = 1
       write(6,*) 'file name:'
       read(5,'(A)') filen 
       open ( IOUNIT , file = filen )
       write(6,*) 'output level: 0?1?2?'
       read(5,*) iout 
    1  read( IOUNIT ,'(A)', end = 90 ) buff 
       call findname (
     i buff ,
     o name , code ) 
       if( code .eq. ' ') goto 1 
       call check (
     i name , 
     a isort , nlist , llist ,
     o num )
       if( code .eq. 'P') then 
          ipack ( num ) = num 
          lpack = lpack + 1 
          mpack ( lpack ) = num 
          numc = num 
       end if
       if( code .eq. 'p') then 
          ipack ( num ) = numc 
       end if
       if( code .eq. 's') then 
          nums = num
       end if 
       if( code .eq. 'c') then 
          irel ( num , nums ) = irel ( num , nums ) + 1 
       end if  
       goto 1 
   90  continue 
       close ( IOUNIT )
       if(iout .ge. 2) then
          write(6,*) 'called routines'
          do 3 k = 1, llist 
             i = isort ( k )
             ncall = 0 
             do 333 j = 1, llist 
  333        ncall = ncall + irel ( j , i )
             if( ncall .gt. 0) then
                write(6,'(1x,A)') nlist ( i ) 
                do 33 jj = 1, llist 
                   j = isort ( jj )
                   if( irel ( j , i ) .gt. 0)  
     *             write(6,'(5x,A,1x,I3)') 
     *             nlist ( j ) , irel ( j , i )
   33           continue
             end if
    3     continue 
          write(6,*)
          write(6,*) 'calling routines'
          do 4 k = 1, llist 
             j = isort ( k )
             write(6,'(1x,A)') nlist ( j ) 
             do 44 ii = 1, llist 
                i = isort ( ii )
                if( irel ( j , i ) .gt. 0) then 
                   write(6,'(5x,A,1x,I3)') nlist ( i ) , irel ( j , i )
                end if
   44        continue
    4     continue 
       end if
       do 1000 loop = 1, 100
       do 100 i = 1, llist 
          do 101 j = 1, llist 
             irelx ( i , j ) = irel ( i , j ) 
  101     continue 
  100  continue
       do 200 i = 1, llist 
          do 201 j = 1, llist 
             irelt = 0 
             if( irel ( i , j ) .gt. 0) irelt = 1
             do 202 k = 1, llist 
                if( ipack ( k ) .eq. 0) then 
                   if( irelx ( i , k )* irelx ( k , j ) .gt. 0)
     *             irelt = 1
                end if
  202        continue 
             irel ( i , j ) = irelt 
  201     continue 
  200  continue
       do 900 i = 1, llist 
       do 901 j = 1, llist 
          if(irel ( i , j ) .ne. irelx ( i , j )) goto 1000
  901  continue 
  900  continue 
       goto 1001
 1000  continue
 1001  continue

       write(6,*) 'call depth =', loop

       do 2000 loop = 1, 100
          do 2100 i = 1, llist 
          do 2101 j = 1, llist 
             irely ( i , j ) = irelx ( i , j ) 
 2101     continue 
 2100  continue
       do 2200 i = 1, llist 
          do 2201 j = 1, llist 
             irelt = 0 
             if( irel ( i , j ) .gt. 0) irelt = 1
             do 2202 k = 1, llist 
                if( irely ( i , k )* irely ( k , j ) .gt. 0)
     *          irelt = 1
 2202        continue 
             irelx ( i , j ) = irelt 
 2201     continue 
 2200  continue
       do 2900 i = 1, llist 
          ireach ( i ) = irelx ( i , 1)
       do 2901 j = 1, llist 
          if( irely ( i , j ) .ne. irelx ( i , j )) goto 2000
 2901  continue 
 2900  continue 
       goto 2001
 2000  continue
 2001  continue

       do 400 j = 1,llist 
          if( ipack ( j ) .gt. 0) then
             do 440 i = 1, llist 
                if( irel ( i , j ) .gt. 0 .and. 
     *          jpack ( i ) .eq. 0) jpack ( i ) = ipack ( j ) 
  440        continue 
             jpack ( j ) = ipack ( j )
          end if
  400  continue 

       do 1400 j = 1,llist 
          if( ipack ( j ) .gt. 0) then
             do 1440 i = 1, llist 
                if( irel ( i , j ) .gt. 0) then 
                   irel ( i , j ) = jpack ( i )
                end if
 1440        continue 
             irel ( j , j ) = jpack ( j )
          end if
 1400  continue 
       if(iout .ge. 1) then 
          write(6,*) 
          write(6,*) 'packaging'
       end if
       do 300 ii = 1, llist 
          i = isort ( ii )   
          if( iout .ge. 1 )
     *    write(6,'(1x,I3,1x,A,1x,20I3)') jpack ( i ),
     *    nlist ( i ), ( irel ( i , mpack ( j )), j = 1, lpack )
          do 330 j = 1, lpack 
             irelij = irel ( i , mpack ( j  ))
             if( irelij .ne. 0 .and. irelij .ne. mpack ( j )) 
     *       listcom ( irelij ) = listcom ( irelij ) + 1
  330     continue  
  300  continue

       write(6,*) 
       write(6,*) 'c  subpackages'
       do 1500 j = 1, lpack 
          write(6,'('' c  '',A,'' subpackage'')') 
     *    nlist ( mpack ( j ) ) 
          do 1550 ii =1, llist 
             i = isort ( ii )  
c             irelij = irel ( i , mpack ( j )) 
             irelij = jpack ( i ) 
             if( irelij .eq. mpack ( j )) 
     *       write(6,'('' c      '',A)') nlist ( i ) 
 1550     continue 
 1500  continue 

       write(6,*) 
       write(6,*) 'c  necessary routines for the execution'
       do 500 j = 1, lpack 
          do 540 i =1, llist 
  540     kpack ( i ) = 0
          write(6,'('' c  '',A,'' requires'')') nlist ( mpack ( j )) 
          do 550 ii =1, llist 
             i = isort ( ii )
             irelij = irelx ( i , mpack ( j )) 
             if( irelij .ge. 1 ) then 
                jpk = jpack ( i ) 
                if( jpk .eq. 0) then
                   write(6,'('' c      '',A)') nlist ( i ) 
                else
                   if( kpack ( jpk ) .eq. 0) then 
                      write(6,'('' c      '',A,'' subpackage'')') 
     *                nlist ( jpk ) 
                      kpack ( jpk ) = 1 
                   end if
                end if 
             end if 
  550     continue 
  500  continue 

       write(6,*) 
       write(6,*) 'common routines'
       do 5 kk = 1, llist 
          k = isort ( kk )
          if(listcom ( k ) .gt. 1) then 
             jpk = jpack ( k ) 
             if( jpk .eq. 0) then
                write(6,'(1x,A)') nlist ( k )
             else
                write(6,'(1x,A,'' subpackage'')') nlist ( k ) 
             end if 
          end if 
    5  continue

       write(6,*) 
       write(6,*) 'unreachable routines'
          do 1560 ii =1, llist 
             i = isort ( ii )
             irelij = ireach ( i ) 
             if( irelij .eq. 0 ) then
                if( ireach ( jpack ( i )) .eq. 0 ) 
     *          write(6,'(5x,A)') nlist ( i ) 
             end if 
 1560     continue 

       write(6,*) 
       write(6,*) 'all routines in alphabetical order'
       do 2560 ii = 1, llist 
          i = isort ( ii ) 
          jpi = jpack ( i )
          if( jpi .eq. 0) then 
             write(6,'(1x,A)') nlist ( i ) 
          else
             write(6,'(1x,A,'' in '',A,'' subpackage'')') 
     *       nlist ( i ), nlist ( jpi ) 
          end if
 2560  continue  
       goto 9100 
      end 

checkpoint:                 lano =   137/129/sp2.@990422.@152623 ........
contents    20.2  findname            
c reusable
      subroutine findname (
     i Buff ,
     o Name , Code )
       parameter ( NSUB = 200 ) 
       character*1 io 
       character*(*) Buff , Name , Code 
c      ........................................................
c      findname  
c      Copyright_OML 1999 M. Ishiguro  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') return
       io = 'O'
       Code = ' ' 
       ipack = 0 
       if(Buff(1:6) .eq. '      ') goto 9201 
       if(Buff(1:6) .eq. 'catch-') goto 9201 
       if(Buff(1:6) .eq. 'CPACK-') then 
          ipack = 2
          goto 9201
       end if
       if(Buff(1:6) .eq. 'cpack-') then 
          ipack = 1
          goto 9201
       end if
       goto 9100 
 9201  continue 
       do 1 i =7,80
          if(Buff( i : i ) .eq. ' ') goto 1 
          if(Buff( i : i ) .eq. 'c') then
             if(Buff( i +1: i +3) .ne. 'all') goto 9100 
             Code = 'c'
             i1 = i + 5
             goto 2 
          end if 
          if(Buff( i : i ) .eq. 's') then
             if(Buff( i +1: i +9) 
     *       .ne. 'ubroutine') goto 9100 
             Code = 's'
             i1 = i + 11 
             goto 2 
          end if 
          if(Buff( i : i +5 ) .eq. 'member') then 
             if( ipack .eq. 1) Code = 'p' 
             if( ipack .eq. 2) Code = 'P' 
             i1 = i + 7 
             goto 2 
          end if 
          if(Buff( i : i ) .eq. 'f') then
             if(Buff( i +1: i +7) 
     *       .ne. 'unction') goto 9100 
             Code = 's'
             i1 = i + 9
             goto 2 
          end if 
          goto 9100
    1  continue 
    2  continue
       do 3 i = i1 , 80
          if( Buff ( i : i ) .eq. ' ' 
     *    .or. Buff ( i : i ) .eq. '(') then
             Name = Buff (i1 : i -1)//' '
             goto 9100 
          end if
    3  continue 
       goto 9100 
      end

checkpoint:                  lano =   138/129/sp2.@990422.@152623 ........
contents    20.3  check               
c reusable
      subroutine check (
     i Name , 
     a Isort , Nlist , Llist ,
     o Num )
       parameter ( NSUB = 200 ) 
       character*(*) Name  
       character*20 Nlist ( NSUB ) 
       character*1 new , io   
       dimension Isort ( NSUB ) 
c      ........................................................
c      check   
c      Copyright_OML 1999 M. Ishiguro  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue
       if( io .eq. 'O') return
       io = 'O'
       call sorta ( 
     i Name , 1, Llist , Isort , Nlist ,
     o ipos , new )
       if( new .eq. 'y' ) then
          Llist = Llist + 1
          Nlist ( Llist ) = Name 
          Num = Llist 
          do 2 i = Llist , ipos + 1, -1
    2     Isort ( i ) = Isort ( i -1)
          Isort ( ipos ) = Llist 
       else 
          Num = ipos 
       end if
       goto 9100
      end

checkpoint:                   lano =   139/129/sp2.@990422.@152623 ........
contents    20.4  sorta               
c reusable
      subroutine sorta (
     i Name , L0 , L1 , Isort , Nlist ,
     o Ipos , New )
       parameter ( NSUB = 200 ) 
       character*(*) Name  
       character*37 alphn 
       character*20 namex , Nlist ( NSUB ) 
       character*1 New , cname , cnamex , io  
       dimension Isort ( NSUB ) 
       data alphn /' 0123456789abcdefghijklmnopqrstuvwxyz'/
c      ........................................................
c      sorta   
c      Copyright_OML 1999 M. Ishiguro  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue  
       if( io .eq. 'O') return
       io = 'O'
       New = 'y'
       lx = ( L0 + L1 ) / 2
       llx = Isort ( lx )
       namex = Nlist ( llx )  
       do 1 i = 1,20
          if( Name ( i : i ) .ne. namex ( i : i )) then 
             cname = Name ( i : i ) 
             cnamex = namex ( i : i ) 
             do 2 j = 1,37
                if( cname .eq. alphn ( j : j )) then 
                   if( lx .le. L0 ) then
                      Ipos = lx 
                   else
                      call sortb (
     i                Name , L0 , lx - 1, Isort , Nlist ,
     o                Ipos , New )
                   end if
                   goto 9100
                end if
                if( cnamex .eq. alphn ( j : j )) then 
                   if( lx .ge. L1 ) then
                      Ipos = lx +1 
                   else
                      call sortb (
     i                Name , lx + 1, L1 , Isort , Nlist ,
     o                Ipos , New )
                   end if
                   goto 9100
                end if
    2        continue
          end if
    1  continue
       New = 'n' 
       Ipos = llx 
       goto 9100
      end

checkpoint:                    lano =   140/129/sp2.@990422.@152623 ........
contents    20.5  sortb               
c reusable
      subroutine sortb (
     i Name , L0 , L1 , Isort , Nlist ,
     o Ipos , New )
       parameter ( NSUB = 200 ) 
       character*(*) Name  
       character*37 alphn 
       character*20 namex , Nlist ( NSUB ) 
       character*1 New , cname , cnamex , io 
       dimension Isort ( NSUB ) 
       data alphn /' 0123456789abcdefghijklmnopqrstuvwxyz'/
c      ........................................................
c      sortb  
c      Copyright_OML 1999 M. Ishiguro  
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue
       if( io .eq. 'O') return
       io = 'O'
       New = 'y' 
       lx = ( L0 + L1 ) / 2
       llx = Isort ( lx )
       namex = Nlist ( llx )  
       do 1 i = 1,20
          if( Name ( i : i ) .ne. namex ( i : i )) then 
             cname = Name ( i : i ) 
             cnamex = namex ( i : i ) 
             do 2 j = 1,37
                if( cname .eq. alphn ( j : j )) then 
                   if( lx .le. L0 ) then
                      Ipos = lx 
                   else
                      call sorta (
     i                Name , L0 , lx - 1, Isort , Nlist ,
     o                Ipos , New )
                   end if
                   goto 9100
                end if
                if( cnamex .eq. alphn ( j : j )) then 
                   if( lx .ge. L1 ) then
                      Ipos = lx +1 
                   else
                      call sorta (
     i                Name , lx + 1, L1 , Isort , Nlist ,
     o                Ipos , New )
                   end if
                   goto 9100
                end if
    2        continue
          end if
    1  continue
       New = 'n'
       Ipos = llx 
       goto 9100
      end
#endif

checkpoint:                     lano =   141/129/sp2.@990422.@152623 ........
#ifdef MOSHIUR
contents  21. moshiur-pack         subpackage
contents    21.1  moshiur           
      subroutine moshiur (
     i Par , Npar , 
     o El , Lel ) 
       implicit real*8 ( a-h , o-z )     
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX  
       common  /cmarts/  mEAN , nSYS , lAGOPT, 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       dimension Par ( Npar ) , El (1)
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      moshiur 
c      Copyright_OML 1999 Md. Moshiur Rahman and M. Ishiguro 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0 = nw ('}' , nw0)
          iw0 = iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('moshiur', io , stio )
          call showm ('I','moshiur version')
          call showr ('I','Par' ,    Par ,      1 , 1 , Npar + 1)
          call showi ('I','Npar' ,   Npar ,     1 , 1 , 1)
          call showm ('I','information supplied through common')
          call showi ('I','kCH' ,    kCH ,      1 , 1 , 1)
          call showi ('I','lISTPE' , lISTPE ,   1 , 1 , kCH )
          call showi ('I','lAGMAX' , lAGMAX ,   1 , 1 , 1)
          call showi ('I','nDATA' ,  nDATA ,    1 , 1 , 1)
          call showr ('O','El' ,     El ,       1 , 1 , Lel + 1)
          call showi ('A','Lel' ,    Lel ,      1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0 = nw ('{' , 0)
          iw0 = iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       my = kCH 
       mv = 3 * kCH 
       lp = 0 
       do 1 j = 1 , kCH 
          lp  =  lp + lISTPE ( j ) - 1 
    1  continue     
       mz = lp + kCH * ( lAGMAX + mEAN +3)
       mn = nDATA 
       maxl  =  kCH ** 2 * lAGMAX + ( lAGMAX - 1) * kCH + 
     * lp * 2 + kCH * ( 3 + mEAN * 2 )
       call martsw (
     i Par , Npar , my , mv , mz , mn , maxl , 
     o El , Lel , 
     w wk ( nw ('var' , my * my )) , 
     w wk ( nw ('ar' , my * my * lAGMAX )) , 
     w wk ( nw ('z' , mz * ( mn + 1))) , 
     w wk ( nw ('v' , mz * mz * ( mn + 1))) , 
     w wk ( nw ('g' , mz * mv )) , 
     w wk ( nw ('sigv' , mv * mv )) , wk ( nw ('sigr' , my * my )) , 
     w wk ( nw ('vf' , maxl )) , iwk ( iw ('irf' , maxl )) ,
     w iwk ( iw ('icf' , maxl )) , 
     w wk ( nw ('vh' , maxl )) , iwk ( iw ('irh' , maxl )) , 
     w iwk ( iw ('ich' , maxl )), wk ( nw ('dop' , mEAN + 3)))
       goto 9100 
      end 

checkpoint:                    lano =   142/129/sp2.@990422.@152623 ........
contents    21.2  gmoshiur            
      subroutine gmoshiur (
     o Par , Npar )
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
#ifdef QMPIFH
       include "mpif.h"
#else
       include (mpif.h)
#endif
#endif 
#include "ardock.env"
       common  /ctdata/ dATA ( MAXN * MAXCH ) , rLIM , kCH , nDATA ,
     * lAGMAX 
       common  /cmarts/  mEAN , nSYS , lAGOPT , 
     * iNDEXM ( MAXCH * MAXCH ) , lISTPE ( MAXCH )  
       common  /cmartb/ lAGLIM , iNITMART , lAGLIST (5) 
       dimension Par ( MAXPAR ) 
       character*1 ckey 
       character*1  io 
#ifdef MODIFIER
       character*1 stio
       data inisub /0/
#endif  
c      .........................................................
c      gmoshiur 
c      Copyright_OML 1999 Md. Moshiur Rahman and M. Ishiguro 
c       The source code of this subroutine, as a part of the ARdock package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
       io = 'I'
 9100  continue 
       if( io .eq. 'O') then
          nw0  =  nw ('}' , nw0)
          iw0  =  iw ('}' , iw0)
       end if
#ifdef MODIFIER
       myself = 9     
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          call selfcom ('gmoshiur', io , stio )                  
          call showm ('I','moshiur version')
          call showr ('O','Par' ,    Par ,    1 , 1 , Npar )     
          call showi ('O','Npar' ,   Npar ,   1 , 1 , 1)
          call selfend ( myself , io , inisub )
       end if 
#endif
       if( io .ne. 'O') then
catch-    call nw
          nw0  =  nw ('{' , 0)
          iw0  =  iw ('{' , 0)
          goto 9200
       end if 
c      ------ 
       return 
c      ====== 
 9200  continue 
       io = 'O'
       if( myid .eq. 0) then 
          call keysave ('i','max AR order:' , 1 , ckey , rx , lAGLIM )
          if( lAGLIM .gt. lAGMAX ) lAGLIM = lAGMAX 
catch-    call jfrex 
          j = j
          j  =  jfrex ('init' , 1)
          j = jfrex ('p' , 1)
          j = jfrex ('s' , 0)
          j = jfrex ('c' , 0)
          j = jfrex ('l' , 0)
          j = jfrex ('1' , 0)
          j = jfrex ('2' , 0)
          j = jfrex ('3' , 0)
          j = jfrex ('4' , 0)
          j = jfrex ('5' , 0)
          j = jfrex ('6' , 0)
          j = jfrex ('7' , 0)
          j = jfrex ('8' , 0)
          j = jfrex ('9' , 0)
          call keysave ('I','mean component: c?l?s?' , 0 , ckey ,
     *    rx , iarg1 )
          mEAN  =  1
          if( ckey .eq. 'p') mEAN = iarg1 + 1 
          if( ckey .eq. '9') mEAN  =  10 
          if( ckey .eq. '8') mEAN  =  9 
          if( ckey .eq. '7') mEAN  =  8 
          if( ckey .eq. '6') mEAN  =  7 
          if( ckey .eq. '5') mEAN  =  6 
          if( ckey .eq. '4') mEAN  =  5 
          if( ckey .eq. '3') mEAN  =  4 
          if( ckey .eq. '2') mEAN  =  3
          if( ckey .eq. 'l') mEAN  =  2 
          if( ckey .eq. 's') mEAN  =  0 
       end if 
#ifdef MPI 
       call mpi_bcast ( lAGLIM , 1 , MPI_INTEGER , 0 , 
     * MPI_COMM_WORLD , ierr )
       call mpi_bcast ( mEAN , 1 , MPI_INTEGER , 0 , 
     * MPI_COMM_WORLD , ierr )
#endif 
       mdiff = mEAN 
       if( mdiff .eq. 0 ) mdiff = 2
       call gmartw (
     i dATA , nDATA , mdiff ,
     o Par , Npar , 
     w wk ( nw ('resid' , nDATA * kCH )), 
     w wk ( nw ('trend' , nDATA * kCH )),
     w wk ( nw ('seas' ,  nDATA * kCH )),
     w wk ( nw ('poly' ,  kCH * mdiff )), 
     w wk ( nw ('trinit', kCH * mdiff )))
       goto 9100 
      end 
checkpoint:                   lano =     0/129/sp2.@990422.@152623 ........
#endif




















