C===========================================================================
C Copyright (C) 1995-2006 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C++++++++++++++++
C.IDENTIFICATION for_try.f
C.LANGUAGE       F77
C.AUTHOR         K. Banse
C.ENVIRONMENT    Any
C.KEYWORDS       FOR to C
C.PURPOSE        Check Fortran to C interface
C.COMMENTS       
C.VERSION  1.0   16-Oct-1990
C 
C 060217	last modif
C 
C 
C this is an extended version of the for_test.for program, to be used
C with ftoc_stack.fc
C to get a look at the stack
C 
C----------------
C 
      CHARACTER*79  s1
      CHARACTER*161 s2
      CHARACTER*4   s3
      CHARACTER*6   s4
      CHARACTER*2   s5
      CHARACTER*23  s6
      CHARACTER*40  st1, st2, st3
C 
      INTEGER    ls1, ls2, ls3, ls4, ls5, ls6
      INTEGER    CTRFLG,KSTART,KSIZE
      INTEGER    MADRID(3)
C 
      COMMON /VMR/ MADRID
C 
      WRITE(*,10100) 
     +     'We expect as I3 numbers: control_flag kstart ksize'
      s1 = 'stack-test '
      OPEN(UNIT=33,FILE=s1(1:10),STATUS='OLD',ERR=9998)
      READ(33,10100,END=9998) ST1
      READ(ST1,10102) CTRFLG,KSTART,KSIZE
      WRITE(*,10101) ST1,CTRFLG,KSTART,KSIZE
C  
 
      s1 = 'sY<01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ>'
      s2 = 's2<abcdefghijklmnopqrstuvwxyz01234567890>XYZ'
      s3 = 's3.X'
      st1 = 'where does this string go? '
      s4 = 'sKlaus'
      st2 = 'filling up space... '
      st3 = '&now, occupying 40 characters over here&& '
      s5 = 'sS'
      s6 = 's[1234567890]AB'
C 
      ls1 = 79
      ls2 = 161
      ls3 = 4
      ls4 = 6
      ls5 = 2
      ls6 = 23
C 
      WRITE(*,995)                      !write title
      WRITE(*,998)
      WRITE(*,996)
C 
      MADRID(1) = KSTART
      MADRID(2) = KSIZE
      MADRID(3) = 33
      CALL CSUB()
C 
      IF ((CTRFLG .EQ. 1) .OR. (CTRFLG .EQ. 10)) THEN
         WRITE(*,2100) 99123
         CALL SSA(99123)
         WRITE(*,2200) 8855,-12
         CALL SSB(8855,-12)
         WRITE(*,1000) s5,ls5
         CALL SSS(s5)
         WRITE(*,2100) -7031
         CALL SSA(-7031)
         WRITE(*,2200) 303,12400
         CALL SSB(303,12400)
         WRITE(*,1000) s2,ls2
         CALL SSS(s2)
         WRITE(*,997)
C 
         WRITE(*,2300) 1000,2000,3000
         CALL SSC(1000,2000,3000)
         WRITE(*,2300) 200,-200,5500
         CALL SSC(200,-200,5500)
         WRITE(*,997)
      ENDIF
C 
      IF ((CTRFLG .EQ. 2) .OR. (CTRFLG .EQ. 10)) THEN
         WRITE(*,1300) 12345,202,s4,ls4
         CALL SSQ(12345,s4,202)
         WRITE(*,1400) s5,ls5,s3,ls3
         CALL SSU(s5,s3)
         WRITE(*,1100) -99,101,7788,-4455
         CALL SSD(-99,101,7788,-4455)
         WRITE(*,1300) -333,444,s1,ls1
         CALL SSQ(-333,s1,444)
         WRITE(*,1400) s6,ls6,s1,ls1
         CALL SSU(s6,s1)
         WRITE(*,1100) 21,-333,-456789,1088
         CALL SSD(21,-333,-456789,1088)
         WRITE(*,997)
      ENDIF
C 
      IF ((CTRFLG .EQ. 3) .OR. (CTRFLG .EQ. 10)) THEN
         WRITE(*,2400) 3,123555,400,-71,555
         CALL SSE(3,123555,400,-71,555)
         WRITE(*,1770) 766,s1,ls1,s3,ls3
         CALL SSR(s1,766,s3)
         WRITE(*,2400) 900,800,700,600,-222
         CALL SSE(900,800,700,600,-222)
         WRITE(*,1770) -111,'ABC',3,s5,ls5
         CALL SSR('ABC',-111,s5)
         WRITE(*,997)
C 
         WRITE(*,1700) s5,ls5,s3,ls3,s4,ls4
         CALL SST(s5,s3,s4)
         WRITE(*,1700) s6,ls6,s1,ls1,s2,ls2
         CALL SST(s6,s1,s2)
         WRITE(*,997)
      ENDIF
C 
      IF ((CTRFLG .EQ. 4) .OR. (CTRFLG .EQ. 10)) THEN
         WRITE(*,1600) 101,202,st1,40,st2,40
         CALL SSV(101,st1,202,st2)
         WRITE(*,1500) -7543,s2,ls2,s4,ls4,s1,ls1
         CALL SSW(s2,s4,-7543,s1)
         WRITE(*,1600) -666,-345,s1,ls1,s2,ls2
         CALL SSV(-666,s1,-345,s2)
         WRITE(*,1500) 3255,s6,ls6,s3,ls3,s5,ls5
         CALL SSW(s6,s3,3255,s5)
         WRITE(*,997)
      ENDIF
C 
      IF ((CTRFLG .EQ. 5) .OR. (CTRFLG .EQ. 10)) THEN
         WRITE(*,2500) 66,-1,77,0,222,1009
         CALL SSF(66,-1,77,0,222,1009)
         WRITE(*,1200) -71,-2,33,s1,ls1,s2,ls2,s3,ls3
         CALL SSP(s1,-71,s2,-2,33,s3)
         WRITE(*,2500) -4321,+567,3300,-223344,567,789
         CALL SSF(-4321,+567,3300,-223344,567,789)
         WRITE(*,1200) 1009,-99,10233,st1,40,s6,ls6,st2,40
         CALL SSP(st1,1009,s6,-99,10233,st2)
         WRITE(*,997)
      ENDIF
C 
      GOTO 9999
C 
C file open error
9998  WRITE(*,10100) 'Problems opening file stack-test ...'
9999  CLOSE(UNIT=33)
C 
995   FORMAT
     +(/'*********************************************************')
996   FORMAT
     +('*********************************************************'/)
997   FORMAT('================================================'//)
998   FORMAT(/'   for_try.for  to test the F77',
     +       ' -> C parameter passing '/)
999   FORMAT('1 ')
1000  FORMAT('calling SSS(str1), str1 = ',A,' : F77 length = ',I4)
1100  FORMAT('calling SSD(n1,n2,n3,n4), n1,n2,n3,n4 = ',4I8)
2100  FORMAT('calling SSA(n1), n1 = ',I8)
2200  FORMAT('calling SSB(n1,n2), n1,n2 = ',2I8)
2300  FORMAT('calling SSC(n1,n2,n3), n1,n2,n3 = ',3I8)
2400  FORMAT('calling SSE(n1,n2,n3,n4,n5), n1,n2,n3,n4,n5 = '/5I8)
2500  FORMAT('calling SSF(n1,n2,n3,n4,n5,n6), n1,n2,n3,n4,n5,n6 = '/6I8)
1200  FORMAT('calling SSP(str1,n1,str2,n2,n3,str3), n1,n2,n3 = ',3I8/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str2 = ',A,': F77 length = ',I4/
     +       'str3 = ',A,': F77 length = ',I4)
1300  FORMAT('calling SSQ(n1,str1,n2), n1, n2 = ',2I8/
     +       'str1 = ',A,': F77 length = ',I4)
1400  FORMAT('calling SSU(str1,str2)'/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str2 = ',A,': F77 length = ',I4)
1500  FORMAT('calling SSW(str1,str2,n1,str3), n1 = ',I8/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str2 = ',A,': F77 length = ',I4/
     +       'str3 = ',A,': F77 length = ',I4)
1600  FORMAT('calling SSV(n1,str1,n2,str2), n1, n2 = ',2I8/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str2 = ',A,': F77 length = ',I4)
1700  FORMAT('calling SST(str1,str2,str3)'/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str2 = ',A,': F77 length = ',I4/
     +       'str3 = ',A,': F77 length = ',I4)
1770  FORMAT('calling SSR(str1,n2,str3), n2 = ',I8/
     +       'str1 = ',A,': F77 length = ',I4/
     +       'str3 = ',A,': F77 length = ',I4)
10100 FORMAT(A)
10101 FORMAT('we read: [',A10,'] and -> ',3I3)
10102 FORMAT(3I3)
C 
      STOP
      END
