      SUBROUTINE HPF(SSPECI,SSPECO,FREQ)                                        
C                                                                               
C  MODULE         HPF                                                           
C  VERSION        1.0                                                           
C  ROUTINE NO     60                                                            
C  LAST MODIFIED  12/02/82                                                      
C  AUTHOR         DAVE POWELL                                                   
C                                                                               
C  THIS SUBROUTINE TAKES A PROTOTYPE LOW PASS FILTER WITH A                     
C  BREAKPOINT AT ANGULAR FREQUENCY 1 RAD/SEC AND CONVERTS TO                    
C  A HIGH PASS FILTER WITH BREAKPOINT AT f=FREQ.                                
C                                                                               
C  PARAMETERS                                                                   
C  **********                                                                   
C                                                                               
C  SSPECI   R*4A  INPUT S-PLANE ARRAY                                           
C  SSPECO   R*4A  OUTPUT S-PLANE ARRAY                                          
C  FREQ     R*4   BREAK FREQUENCY                                               
C                                                                               
C  THE LENGTH OF SSPECI AND SSPECO ARE INDETERMINANT                            
      REAL*4 SSPECI(9999),SSPECO(9999),FREQ                                     
C                                                                               
C  GLOBAL VARIABLES                                                             
C  ****************                                                             
C                                                                               
$INCLUDE SIGPRO10.CMN(NLIST)                                                    
$INCLUDE SPLANE10.CMN(NLIST)                                                    
C                                                                               
C                                                                               
C  LOCAL VARIABLES                                                              
C  ***************                                                              
C                                                                               
      REAL*4 PI,W                                                               
      INTEGER*4 NSI,INFNO,ISI,ITS,NSO,ISO,IPSI,IPS,RTN,IER                      
      COMPLEX*8 SGAIN,SPOS                                                      
      PARAMETER (RTN=60)                                                        
C                                                                               
C  (1) CHECK PARAMETERS                                                         
C  ********************                                                         
C                                                                               
      IF (SSPECI(PSX).NE.PSV) GOTO 9001                                         
      IF (FREQ.LT.0.0) GOTO 9003                                                
      NSI=INT(SSPECI(PSN))                                                      
      IF (NSI.LT.0) GOTO 9004                                                   
C                                                                               
C  (2) INITIALISE                                                               
C  **************                                                               
C                                                                               
      SSPECO(PSX)=PSV                                                           
      PI=4.0*ATAN(1.0)                                                          
      W=2.0*PI*FREQ                                                             
      INFNO=0                                                                   
C                                                                               
C  (3) WORK OUT LENGTH REQUIRED FOR OUTPUT ARRAY                                
C  *********************************************                                
C                                                                               
      IF (NSI.LT.0) GOTO 3100                                                   
      DO 3000 ISI=1,NSI                                                         
          IPSI=PSH+1+PSE*(ISI-1)                                                
C         Check sequence number of singularity.                                 
          IF (INT(SSPECI(IPSI+PSM)).NE.ISI) GOTO 9005                           
C         Increment counter according to s-plane type.                          
          ITS=INT(SSPECI(IPSI+PST))                                             
C                                                                               
C         Real Zero.                                                            
          IF (ITS.EQ.PSTRZ) THEN                                                
              INFNO=INFNO-1                                                     
C                                                                               
C         Real Pole.                                                            
          ELSEIF (ITS.EQ.PSTRP) THEN                                            
              INFNO=INFNO+1                                                     
C                                                                               
C         Complex Zero.                                                         
          ELSEIF (ITS.EQ.PSTCZ) THEN                                            
              INFNO=INFNO-1                                                     
C                                                                               
C         Complex Pole.                                                         
          ELSEIF (ITS.EQ.PSTCP) THEN                                            
              INFNO=INFNO+1                                                     
C                                                                               
C         Complex Conjugate Zero Pair.                                          
          ELSEIF (ITS.EQ.PST2Z) THEN                                            
              INFNO=INFNO-2                                                     
C                                                                               
C         Complex Conjugate Pole Pair.                                          
          ELSEIF (ITS.EQ.PST2P) THEN                                            
              INFNO=INFNO+2                                                     
C                                                                               
C         Singularity Type not recognised.                                      
          ELSE                                                                  
              GOTO 9006                                                         
          ENDIF                                                                 
C                                                                               
3000  CONTINUE                                                                  
3100  CONTINUE                                                                  
C                                                                               
C     Work out required length for output array SSPECO.                         
      IF ((INFNO/2)*2.EQ.INFNO) THEN                                            
          NSO=IABS(INFNO)/2+NSI                                                 
      ELSE                                                                      
          NSO=(IABS(INFNO)+1)/2+NSI                                             
      ENDIF                                                                     
      SSPECO(PSN)=NSO                                                           
C                                                                               
C     Check output array SSPECO is long enough.                                 
      IF (PSH+PSE*NSO.GT.INT(SSPECO(PSL))) THEN                                 
          GOTO 9007                                                             
      ENDIF                                                                     
C     Change max used length if necessary.                                      
      IF (PSH+PSE*NSO.GT.INT(SSPECO(PSU))) THEN                                 
          SSPECO(PSU)=PSH+PSE*NSO                                               
      ENDIF                                                                     
C                                                                               
C  (4) CALCULATION FOR EACH SINGULARITY - OUTPUT IN SSPECO                      
C  *******************************************************                      
C                                                                               
      IF (NSO.LE.0) GOTO 4100                                                   
C     Sweep over singularities.                                                 
      DO 4000 ISI=1,NSI                                                         
          IPS=PSH+1+PSE*(ISI-1)                                                 
          ITS=INT(SSPECI(IPS+PST))                                              
          SGAIN=CMPLX(SSPECI(IPS+PSG),SSPECI(IPS+PSJ))                          
          SPOS=CMPLX(SSPECI(IPS+PSR),SSPECI(IPS+PSI))                           
C                                                                               
C         Real Zero.                                                            
          IF (ITS.EQ.PSTRZ) THEN                                                
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PSTRZ                                             
              SSPECO(IPS+PSG)=-REAL(SGAIN)*REAL(SPOS)                           
              SSPECO(IPS+PSJ)=-AIMAG(SGAIN)*REAL(SPOS)                          
              SSPECO(IPS+PSR)=W/REAL(SPOS)                                      
              SSPECO(IPS+PSI)=0.0                                               
C                                                                               
C         Real Pole.                                                            
          ELSEIF (ITS.EQ.PSTRP) THEN                                            
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PSTRP                                             
              SSPECO(IPS+PSG)=-REAL(SGAIN)/REAL(SPOS)                           
              SSPECO(IPS+PSJ)=-AIMAG(SGAIN)/REAL(SPOS)                          
              SSPECO(IPS+PSR)=W/REAL(SPOS)                                      
              SSPECO(IPS+PSI)=0.0                                               
C                                                                               
C         Complex Zero.                                                         
          ELSEIF (ITS.EQ.PSTCZ) THEN                                            
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PSTCZ                                             
              SSPECO(IPS+PSG)=-REAL(SGAIN*SPOS)                                 
              SSPECO(IPS+PSJ)=-AIMAG(SGAIN*SPOS)                                
              SSPECO(IPS+PSR)=REAL(W/SPOS)                                      
              SSPECO(IPS+PSI)=AIMAG(W/SPOS)                                     
C                                                                               
C         Complex Pole.                                                         
          ELSEIF (ITS.EQ.PSTCP) THEN                                            
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PSTCP                                             
              SSPECO(IPS+PSG)=-REAL(SGAIN/SPOS)                                 
              SSPECO(IPS+PSJ)=-AIMAG(SGAIN/SPOS)                                
              SSPECO(IPS+PSR)=REAL(W/SPOS)                                      
              SSPECO(IPS+PSI)=AIMAG(W/SPOS)                                     
C                                                                               
C         Complex conjugate zero pair.                                          
          ELSEIF (ITS.EQ.PST2Z) THEN                                            
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PST2Z                                             
              SSPECO(IPS+PSG)=REAL(SGAIN)*(CABS(SPOS)**2)                       
              SSPECO(IPS+PSJ)=AIMAG(SGAIN)*(CABS(SPOS)**2)                      
              SSPECO(IPS+PSR)=REAL(W/SPOS)                                      
              SSPECO(IPS+PSI)=AIMAG(W/SPOS)                                     
C                                                                               
C         Complex conjugate pole pair.                                          
          ELSEIF (ITS.EQ.PST2P) THEN                                            
              SSPECO(IPS+PSM)=ISI                                               
              SSPECO(IPS+PST)=PST2P                                             
              SSPECO(IPS+PSG)=REAL(SGAIN)/(CABS(SPOS)**2)                       
              SSPECO(IPS+PSJ)=AIMAG(SGAIN)/(CABS(SPOS)**2)                      
              SSPECO(IPS+PSR)=REAL(W/SPOS)                                      
              SSPECO(IPS+PSI)=AIMAG(W/SPOS)                                     
C                                                                               
          ENDIF                                                                 
4000  CONTINUE                                                                  
4100  CONTINUE                                                                  
C                                                                               
C  (5) APPEND PAIRS OF POLES/ZEROS AT S=0.0                                     
C  ****************************************                                     
C                                                                               
      ISO=NSI                                                                   
      IF (IABS(INFNO)/2.LE.0) GOTO 5100                                         
      DO 5000 IS=1,IABS(INFNO)/2                                                
          ISO=ISO+1                                                             
          IPSO=PSH+1+PSE*(ISO-1)                                                
          SSPECO(IPSO+PSM)=ISO                                                  
          IF (INFNO.GT.0) THEN                                                  
              SSPECO(IPSO+PST)=PST2Z                                            
          ELSE                                                                  
              SSPECO(IPSO+PST)=PST2P                                            
          ENDIF                                                                 
          SSPECO(IPSO+PSG)=1.0                                                  
          SSPECO(IPSO+PSJ)=0.0                                                  
          SSPECO(IPSO+PSR)=0.0                                                  
          SSPECO(IPSO+PSI)=0.0                                                  
5000  CONTINUE                                                                  
5100  CONTINUE                                                                  
C                                                                               
C  (6) APPEND SINGLE REMAINING POLE/ZERO - IF ONE                               
C  **********************************************                               
C                                                                               
      IF ((INFNO/2)*2.EQ.INFNO) GOTO 6100                                       
      ISO=ISO+1                                                                 
      IPSO=PSH+1+PSE*(ISO-1)                                                    
      SSPECO(IPSO+PSM)=ISO                                                      
      IF (INFNO.GT.0) THEN                                                      
          SSPECO(IPSO+PST)=PSTRZ                                                
      ELSE                                                                      
          SSPECO(IPSO+PST)=PSTRP                                                
      ENDIF                                                                     
      SSPECO(IPSO+PSG)=1.0                                                      
      SSPECO(IPSO+PSJ)=0.0                                                      
      SSPECO(IPSO+PSR)=0.0                                                      
      SSPECO(IPSO+PSI)=0.0                                                      
6100  CONTINUE                                                                  
C                                                                               
      RETURN                                                                    
C                                                                               
C  (7) GENERAL ERROR EXIT                                                       
C  **********************                                                       
C                                                                               
C     Input array not of correct type.                                          
9001  CONTINUE                                                                  
      IER=14                                                                    
      GOTO 9999                                                                 
C                                                                               
C     Frequency is less than zero.                                              
9003  CONTINUE                                                                  
      IER=15                                                                    
      GOTO 9999                                                                 
C                                                                               
C     Input array is set up incorrectly.                                        
9004  CONTINUE                                                                  
      IER=16                                                                    
      GOTO 9999                                                                 
C                                                                               
C     Error in sequence number in Input array.                                  
9005  CONTINUE                                                                  
      IER=18                                                                    
      GOTO 9999                                                                 
C                                                                               
C     Singularity type not recognised.                                          
9006  CONTINUE                                                                  
      IER=9                                                                     
      GOTO 9999                                                                 
C                                                                               
C     Output array not long enough.                                             
9007  CONTINUE                                                                  
      IER=17                                                                    
C                                                                               
9999  CONTINUE                                                                  
C                                                                               
      CALL UERERR('FILTER',RTN,IER,0,'E')                                       
      CALL UERREP('FILTER',RTN,.TRUE.)                                          
C                                                                               
      RETURN                                                                    
      END                                                                       
