      PROGRAM SHADTST                                                                                                               
C     PROGRAM SHADTST(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT)                    A2                                                  
C     ----------------------------------------------------------------          A2                                                  
C                                                                                                                                   
C     NOV 20/07 - F.MAJAESS (MAKE "INTPR" COMMON BLOCK DECLARATION CONSISTENT   A2                                                  
C                            WITH THAT IN THE OTHER SOURCE CODE)                A2                                                  
C     NOV 07/07 - F.MAJAESS (REVISED TO USE "PCHIQU" INSTEAD OF "PWRITX")                                                           
C     MAR 11/04 - M.BERKLEY (MODIFIED for NCAR V3.2)                                                                                
C     JUL  1/98 - M.BERKLEY(CLEAN UP AND UPGRADE TO NCAR 4.0.1)                                                                     
C     AUG   /91 - F.ZWIERS/S.WILSON                                                                                                 
C                                                                               A2                                                  
CSHADTST - PRODUCE SAMPLE SHADING PATTERNS                                      A1                                                  
C                                                                               A3                                                  
CAUTHOR - F.ZWIERS/S.WILSON                                                     A3                                                  
C                                                                               A3                                                  
CPURPOSE - PRODUCE SAMPLE SHADING PATTERNS                                      A3                                                  
C                                                                               A3                                                  
CCARD READ....                                                                  A5                                                  
C                                                                               A5                                                  
C      READ(5,5010) ICLR                                                        A5                                                  
C 5010 FORMAT(10X,I5)                                                           A5                                                  
C                                                                               A5                                                  
C      ICLR = 0 (TO PRODUCE MONOCHROME SAMPLE SHADING PATTERNS)                 A5                                                  
C      ICLR = 1 (TO PRODUCE COLOUR SAMPE SHADING PATTERNS)                      A5                                                  
C                                                                               A5                                                  
CEXAMPLE OF INPUT CARD...                                                       A5                                                  
C                                                                               A5                                                  
C* SHADTST    1                                                                 A5                                                  
C-----------------------------------------------------------------------------                                                      
C                                                                                                                                   
      REAL            HSVV(3,16)                                                                                                    
      CHARACTER*83    TITLE                                                                                                         
      INTEGER IPAT(16)                                                                                                              
                                                                                                                                    
C--------------------------------------------------------------------                                                               
C     DASHLINE Common Block                                                                                                         
      COMMON /INTPR/                                                                                                                
     1     IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE,ICLOSE                                                                   
      INTEGER IPAU,NP,L1,MLLINE,ICLOSE                                                                                              
      REAL FPART,TENSN,SMALL,ADDLR,ADDTB                                                                                            
                                                                                                                                    
      COMMON /PUSER/MODE                                                                                                            
C                                                                                                                                   
C     * DECLARE NCAR PLUGINS EXTERNAL, SO CORRECT VERSION ON SGI                                                                    
C                                                                                                                                   
      EXTERNAL BFCRDF,DFNCLR,GSLWSC,PCHIQU,PCSETI,NEW_HAFTNP,                                                                       
     1         SAMPLE,SETPAT                                                                                                        
C                                                                                                                                   
C     * DECLARE BLOCK DATAS EXTERNAL, SO INITIALIZATION HAPPENS                                                                     
C                                                                                                                                   
      EXTERNAL FILLPAT_BD                                                                                                           
C                                                                                                                                   
      MLLINE=43                                                                                                                     
      NF=2                                                                                                                          
      CALL JCLPNT(NF,5,6)                                                                                                           
      CALL PSTART                                                                                                                   
                                                                                                                                    
C     * TELL PCHIQU TO USE THE DUPLEX CHARACTER FONT                                                                                
      CALL PCSETI('FN',12)                                                                                                          
                                                                                                                                    
C     * SET BACKGROUND COLOR                                                                                                        
      CALL BFCRDF(0)                                                                                                                
                                                                                                                                    
C     * SET LINE WIDTH                                                                                                              
      CALL GSLWSC(2.0)                                                                                                              
                                                                                                                                    
      CALL SETUSV('MS',500)                                                                                                         
C                                                                                                                                   
C     * SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE                                                                             
C                                                                                                                                   
      CALL GSELNT(0)                                                                                                                
                                                                                                                                    
C!!!                                                                                                                                
C     ISOLID=177777B                                                                                                                
      ISOLID='177777'O                                                                                                              
C     ISOLID=65535                                                                                                                  
C!!!                                                                                                                                
      CALL DASHDB(ISOLID)                                                                                                           
      CALL SET(0.005,0.995,0.005,0.995, 0.,1.,0.,1., 1)                                                                             
                                                                                                                                    
      READ(5,5010,END=10) ICLR                                                                                                      
      WRITE(*,*)ICLR                                                                                                                
      GOTO 20                                                                                                                       
   10 CONTINUE                                                                                                                      
         WRITE(6,6010)                                                                                                              
         CALL                                      PXIT('SHADTST',-1)                                                               
   20 CONTINUE                                                                                                                      
                                                                                                                                    
      IF (ICLR.NE.0) THEN                                                                                                           
C        * COLOURS                                                                                                                  
         CALL DFCLRS(0,HSVV,IPAT)                                                                                                   
         TITLE='PATTERNS 100-135 (COLOUR)'                                                                                          
         NC=25                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),32.,0.0,0.0)                                                                             
         IPTMIN = 100                                                                                                               
         IPTMAX = 135                                                                                                               
         CALL SAMPLE(IPTMIN,IPTMAX,6,6)                                                                                             
                                                                                                                                    
         TITLE='PATTERNS 140-199 (COLOUR)'                                                                                          
         NC=25                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),32.,0.0,0.0)                                                                             
         IPTMIN = 140                                                                                                               
         IPTMAX = 199                                                                                                               
         CALL SAMPLE(IPTMIN,IPTMAX,10,6)                                                                                            
                                                                                                                                    
         TITLE='PATTERNS 350-419 (COLOUR)'                                                                                          
         NC=25                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),32.,0.0,0.0)                                                                             
         IPTMIN = 350                                                                                                               
         IPTMAX = 419                                                                                                               
         CALL SAMPLE(IPTMIN,IPTMAX,10,7)                                                                                            
                                                                                                                                    
      ELSE                                                                                                                          
C        * MONOCHROME                                                                                                               
         CALL DFCLRS(0,HSVV,IPAT)                                                                                                   
         TITLE='PATTERNS 22-45'                                                                                                     
         NC=14                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),36.,0.0,0.0)                                                                             
         IPTMIN = 22                                                                                                                
         IPTMAX = 45                                                                                                                
         CALL SAMPLE(IPTMIN,IPTMAX,6,4)                                                                                             
                                                                                                                                    
         TITLE='PATTERNS 65-92'                                                                                                     
         NC=14                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),36.,0.0,0.0)                                                                             
         IPTMIN = 65                                                                                                                
         IPTMAX = 96                                                                                                                
         CALL SAMPLE(IPTMIN,IPTMAX,8,4)                                                                                             
                                                                                                                                    
         TITLE='PATTERNS 200-249'                                                                                                   
         NC=16                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),36.,0.0,0.0)                                                                             
         IPTMIN = 200                                                                                                               
         IPTMAX = 249                                                                                                               
         CALL SAMPLE(IPTMIN,IPTMAX,10,5)                                                                                            
                                                                                                                                    
         TITLE='PATTERNS 250-299'                                                                                                   
         NC=16                                                                                                                      
         CALL PCHIQU(0.5,0.975,TITLE(1:NC),36.,0.0,0.0)                                                                             
         IPTMIN = 250                                                                                                               
         IPTMAX = 299                                                                                                               
         CALL SAMPLE(IPTMIN,IPTMAX,10,5)                                                                                            
                                                                                                                                    
C         TITLE='PATTERNS 300-349'                                                                                                  
C         NC=16                                                                                                                     
C         CALL PCHIQU(0.5,0.975,TITLE(1:NC),36.,0.0,0.0)                                                                            
C         IPTMIN = 300                                                                                                              
C         IPTMAX = 349                                                                                                              
C         CALL SAMPLE(IPTMIN,IPTMAX,10,5)                                                                                           
      ENDIF                                                                                                                         
                                                                                                                                    
      CALL                                         PXIT('SHADTST',0)                                                                
C-----------------------------------------------------------------------------                                                      
 5010 FORMAT(10X,I5)                                                                                                                
 6010 FORMAT('0********** NO COLOUR SWITCH SPECIFIED **************')                                                               
                                                                                                                                    
      END                                                                                                                           
