home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / TIDY621.ZIP / KUPPER.UNX < prev    next >
Encoding:
Text File  |  1989-02-15  |  5.7 KB  |  72 lines
  1.       character*2 function kupper(c)                                            
  2. c                                                                               
  3. c     CONVERTS LOWER-CASE LETTERS TO UPPER-CASE. SEMI-PORTABLE VERSION.         
  4. c     ALGORITHM ALLOWS FOR NON-ALPHABETIC CHARACTERS WITHIN THE (a-z)           
  5. c     INTERVAL (AS WITH EBCDIC)                                                 
  6. c                                                                               
  7. c     AL STANGENBERGER, FORESTRY, U.C. BERKELEY  AUGUST 1988                    
  8. c                                                                               
  9. c     PARAMETERS:                                                               
  10. c       ICA  = DECIMAL CODE FOR UPPER-CASE A                                    
  11. c       ICZ  = DECIMAL CODE FOR UPPER-CASE Z                                    
  12. c       ICLA = DECIMAL CODE FOR LOWER-CASE a                                    
  13. c       ICLZ = DECIMAL CODE FOR UPPER-CASE z                                    
  14. c                                                                               
  15. c     ASCII PARAMETERS                                                          
  16. c     PARAMETER (ICA=65,ICLA=97,ICZ=90,ICLZ=122)                                
  17. c                                                                               
  18. c     EBCDIC PARAMETERS                                                         
  19. c     PARAMETER (ICA=193,ICLA=129,ICZ=233,ICLZ=169)                             
  20. c                                                                               
  21. c     UNIX ASCII PARAMETERS FOR FORCING TO LOWER CASE                           
  22.       parameter (icla=65,ica=97,iclz=90,icz=122)                                
  23. c                                                                               
  24.       character c2                                                              
  25.       character*2 tbl(icla:iclz),c,kbl                                          
  26.       character*26 lC,UC                                                        
  27.       logical setup                                                             
  28. c                                                                               
  29. c     NORMAL UPPER/LOWER CASE STRINGS                                           
  30. c     DATA LC/'abcdefghijklmnopqrstuvwxyz'/                                     
  31. c     DATA UC/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/                                     
  32. c                                                                               
  33. c     REVERSED STRINGS FOR UNIX TO FORCE LOWER-CASE                             
  34.       data uc/'abcdefghijklmnopqrstuvwxyz'/                                     
  35.       data lc/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/                                     
  36. c                                                                               
  37.       data setup/.true./                                                        
  38.       data kbl/' @'/                                                            
  39. c                                                                               
  40. c     BUILD TRANSLATION TABLE FIRST PASS.                                       
  41. c     (NOTE - EBCDIC HAS SOME NON-ALPHABETIC CHARS IN THE INTERVAL, SO          
  42. c      BUILD A TABLE WHICH WON'T TRANSLATE THEM.)                               
  43.       if (setup) then                                                           
  44.            j=1                                                                  
  45.            do 10 i=icla,iclz                                                    
  46.                 tbl(i)='  '                                                     
  47.                 c2=char(i)                                                      
  48.                 if (c2.eq.lc(j:j)) then                                         
  49.                      tbl(i)(1:1)=uc(j:j)                                        
  50.                      j=j+1                                                      
  51.                 else                                                            
  52.                      tbl(i)(1:1)=c2(1:1)                                        
  53.                 end if                                                          
  54.  10        continue                                                             
  55. c                                                                               
  56.            setup=.false.                                                        
  57.       end if                                                                    
  58.       if (c(2:2).eq.kbl(2:2)) then                                              
  59.            kupper=c                                                             
  60.            return                                                               
  61.       end if                                                                    
  62. c                                                                               
  63. c     IF C OUTSIDE OF LOWER-CASE RANGE, RETURN                                  
  64.       i=ichar(c(1:1))                                                           
  65.       if (i.ge.icla.and.i.le.iclz) then                                         
  66.            kupper=tbl(i)                                                        
  67.       else                                                                      
  68.            kupper=c                                                             
  69.       end if                                                                    
  70.       return                                                                    
  71.       end                                                                       
  72.