        program test1
C       program to test the FITSIO subroutine package by creating a FITS
C       file with a primary array, an ASCII table, and a binary table.

        integer iunit,status,bitpix,naxis,naxes(99),pcount,gcount
        integer group,fpixel,nelem,i,htype,nkeys,nmore
        integer ivalue(10000),jval
        logical simple,extend
        integer nrows,tfield,tbcol(10),rowlen,inulls(10)
        character*16 ttype(10),tform(10),tunit(10),extnam
        character*8 carray(4),cnulls(10)
        character record*80,comm*40 ,sval*20
        logical larray(4),lval,anyf
        integer*2 iarray(4),ival
        integer jarray(4)
        real farray(4),earray(4),eval,fval
        double precision darray(4),dval,gval,tscale,tzero
        complex comp(4),comval

        status=0
        iunit=15
C       open the new FITS file
        call ftinit(iunit,'test1.fit',2880,status)
        print *,'Opened new FITS file: ftinit status:',status

        simple=.true.
        bitpix=32
        naxis=2
        naxes(1)=10
        naxes(2)=2
        pcount=0
        gcount=1
        extend=.true.

C       write the required primary array keywords
        call ftphpr(iunit,simple,bitpix,naxis,naxes,pcount,gcount,
     &       extend,status)
        print *,'Wrote required primary keywords: ftpprh status:',status

C       test the ftprec subroutine
        record='          This record was written by FTPREC'
        call ftprec(iunit,record,status)
        print *,'Wrote 80 byte record: ftprec status:',status

C       test writing a keyword with each possible data type
        call ftpkyj(iunit,'jkey',-35,'The value is -35',status)
        call ftpkyl(iunit,'lkey',.true.,'The value is TRUE',status)
        call ftpkys(iunit,'skey','Books','The value is Books',status)
        call ftpkys(iunit,'sqkey','O''Hara''s knees'' ',
     &              'The value is O''Hara''s knees'' ',status)
        call ftpkye(iunit,'ekey',-12.121212,8,
     &  'The value is -1.2121212E+01',status)
        dval=-7.8787878787878787878D+03
        call ftpkyd(iunit,'dkey',dval,15,
     &  'The value is -7.878787878787878E+03',status)
        call ftpkyf(iunit,'fkey',23.232323,5,
     &  'The value is 23.23232',status)
        dval=-4.3434343434343D+03
        call ftpkyg(iunit,'gkey',dval,10,
     &  'The value is -4343.4343434343',status)
        print *,'Wrote keyword of every datatype: ftpkyX status',status

        print *,'Now read back each keyword with no type conversion:'
        call ftgkyj(iunit,'jkey',jval,comm,status)
        print *,'JKEY:',jval,comm,status
        call ftgkyl(iunit,'lkey',lval,comm,status)
        print *,'LKEY:',lval,comm,status
        call ftgkys(iunit,'skey',sval,comm,status)
        print *,'SKEY:',sval,comm,status
        call ftgkys(iunit,'sqkey',sval,comm,status)
        print *,'SQKEY:',sval,comm,status
        call ftgkye(iunit,'ekey',eval,comm,status)
        print *,'EKEY:',eval,comm,status
        call ftgkyd(iunit,'dkey',dval,comm,status)
        print *,'DKEY:',dval,comm,status
        call ftgkye(iunit,'fkey',fval,comm,status)
        print *,'FKEY:',fval,comm,status
        call ftgkyd(iunit,'gkey',gval,comm,status)
        print *,'GKEY:',gval,comm,status

        print *,'Now read back each keyword with datatype conversion:'
        call ftgkye(iunit,'jkey',eval,comm,status)
        print *,'ftgkye read JKEY with value, status =',eval, status
        call ftgkyd(iunit,'jkey',dval,comm,status)
        print *,'ftgkyd read JKEY with value, status =',dval, status
        call ftgkyj(iunit,'ekey',jval,comm,status)
        print *,'ftgkyj read EKEY with value, status =',jval, status
        call ftgkyj(iunit,'dkey',jval,comm,status)
        print *,'ftgkyj read DKEY with value, status =',jval, status
        call ftgkyj(iunit,'fkey',jval,comm,status)
        print *,'ftgkyj read FKEY with value, status =',jval, status
        call ftgkyj(iunit,'gkey',jval,comm,status)
        print *,'ftgkyj read GKEY with value, status =',jval, status

        print *,'Read string as an integer; should get error 403'
        jval=0
        call ftgkyj(iunit,'skey',jval,comm,status)
        print *,'ftgkyj read SKEY with value, status =',jval, status
        if (status .eq. 403)status=0

        call ftpcom(iunit,'This was written by FTPCOM',status)
        print *,'ftpcom status=',status

        call ftphis(iunit,'This was written by FTPHIS',status)
        print *,'ftphis status=',status

        call ftpdat(iunit,status)
        print *,'wrote DATE: ftpdat status=',status

        call ftgkys(iunit,'DATE',sval,comm,status)
        print *,comm,sval

C       now delete the date keyword (so that the output FITS file is
C       always identical
        call ftdkey(iunit,'DATE',status)
        print *,'Deleted the DATE keyword.  ftdkey status = ',status

        group=1
        fpixel=1
        nelem=20

C       set the values for the primary array
        do 14 i=1,nelem
                ivalue(i)=i+64
14      continue

        call ftpdef(iunit,bitpix,naxis,naxes,pcount,gcount,status)
        print *,'Defined array structure: ftpdef status',status

C       we will come back to write the primary array data after the
C       extensions have been written.
        call ftpprj(iunit,group,fpixel,1,ivalue,status)
        print *,'Wrote 1st element of array: ftppri status',status

        print *,' '
        print *,'Now do the ASCII table extension...'
        call ftcrhd(iunit,status)
        print *,'Created a new HDU: ftcrhd status',status

        nrows=4
        tfield=5
        ttype(1)='Name'
        ttype(2)='Ivalue'
        ttype(3)='Fvalue'
        ttype(4)='Evalue'
        ttype(5)='Dvalue'
        tform(1)='A8'
        tform(2)='I10'
        tform(3)='F14.6'
        tform(4)='E12.5'
        tform(5)='D21.14'
        tbcol(1)=1
        tbcol(2)=10
        tbcol(3)=21
        tbcol(4)=36
        tbcol(5)=49
        rowlen=69
        tunit(1)=' '
        tunit(2)='m**2 '
        tunit(3)='cm'
        tunit(4)='erg/s'
        tunit(5)='km/s'

        extnam='Test-ASCII'
        pcount=0

        call ftphtb(iunit,rowlen,nrows,tfield,ttype,
     &   tbcol,tform,tunit,extnam,status)
        print *,'Wrote required table header: ftptbh status',status

        call ftadef(iunit,rowlen,tfield,tbcol,tform,nrows,status)
        print *,'Defined ASCII table structure: ftadef status',status

C       define scaling for the integer column
        tscale=3.2
        tzero=-4.
        call ftpkyd(iunit,'tscal2',tscale,4,
     &  'Scale factor for field 2',status)
        call ftpkyd(iunit,'tzero2',tzero,4,
     &  'Scaling offset for field 2',status)
        call fttscl(iunit,2,tscale,tzero,status)
        print *,'Defined scaling for column 2: fttscl status=',status

        carray(1)='NGC4501'
        carray(2)='M51'
        carray(3)=' '
        jarray(1)=15000
        jarray(2)=-15000
        farray(1)=15000.
        farray(2)=-15000.
        earray(1)=1.23456
        earray(2)=-1.23456
        darray(1)= 1.234567890123456789D03
        darray(2)=-1.234567890123456789D-03

        print *,'Write the first 2 rows to the ASCII table:'
        call ftpcls(iunit,1,1,1,2,carray,status)
        print *,'ftpcls status',status
        call ftpclj(iunit,2,1,1,2,jarray,status)
        print *,'ftpclj status',status
        call ftpcle(iunit,3,1,1,2,farray,status)
        print *,'ftpcle status',status
        call ftpcle(iunit,4,1,1,2,earray,status)
        print *,'ftpcle status',status
        call ftpcld(iunit,5,1,1,2,darray,status)
        print *,'ftpcld status',status


        cnulls(1)='NULL1'
        cnulls(2)='NULL2'
        cnulls(3)='NULL3'
        cnulls(4)='NULL4'
        cnulls(5)='NULL5'
        call ftpkns(iunit,'TNULL',1,5,cnulls,'Null values&',status)
        print *,'Wrote null value strings to header: ftpkns:',status

        call ftsnul(iunit,1,cnulls(1),status)
        call ftsnul(iunit,2,cnulls(2),status)
        call ftsnul(iunit,3,cnulls(3),status)
        call ftsnul(iunit,4,cnulls(4),status)
        call ftsnul(iunit,5,cnulls(5),status)
        print *,'Defined null value strings: ftsnul status = ',status

        call ftpclu(iunit,1,3,1,1,status)
        call ftpclu(iunit,2,3,1,1,status)
        call ftpclu(iunit,3,3,1,1,status)
        call ftpclu(iunit,4,3,1,1,status)
        call ftpclu(iunit,5,3,1,1,status)
        print *,'Set 3rd row undefined: ftpclu status = ',status

        print *,'Write the 4th row with datatype conversion:'
        call ftpcls(iunit,1,4,1,1,carray,status)
        print *,'ftpcls status',status
        farray(1)=1000.5
        call ftpcle(iunit,2,4,1,1,farray,status)
        print *,'ftpcle status',status
        jarray(1)=42
        call ftpclj(iunit,3,4,1,1,jarray,status)
        print *,'ftpclj status',status
        call ftpclj(iunit,4,4,1,1,jarray,status)
        print *,'ftpclj status',status
        call ftpclj(iunit,5,4,1,1,jarray,status)
        print *,'ftpclj status',status
        
C       initialize the arrays to be filled by reading back the table
        carray(1)=' '
        carray(2)=' '
        jarray(1)=0
        jarray(2)=0
        farray(1)=0.
        farray(2)=0.
        earray(1)=0.
        earray(2)=0.
        darray(1)=0.
        darray(2)=0.

        print *,'Reading ASCII table with no implicit type conversion:'
        call ftgcvs(iunit,1,1,1,4,'NULL',carray,anyf,status)
        print *,'ftgcvs values, anyf,status=',carray,anyf,status
        call ftgcvj(iunit,2,1,1,4,-99,jarray,anyf,status)
        print *,'ftgcvj values, anyf,status',jarray,anyf,status
        call ftgcve(iunit,3,1,1,4,-99.,farray,anyf,status)
        print *,'ftgcve values, anyf,status',farray,anyf,status
        call ftgcve(iunit,4,1,1,4,-99.,earray,anyf,status)
        print *,'ftgcve values, anyf,status',earray,anyf,status
        dval=-99.
        call ftgcvd(iunit,5,1,1,4,dval,darray,anyf,status)
        print *,'ftgcvd values, anyf,status',darray,anyf,status

        print *,'Reading ASCII table with implicit type conversion:'
        call ftgcve(iunit,2,1,1,4,-999.,earray,anyf,status)
        print *,'ftgcve values, anyf,status',earray,anyf,status
        call ftgcvj(iunit,3,1,1,4,-999,jarray,anyf,status)
        print *,'ftgcvj values, anyf,status',jarray,anyf,status
        call ftgcvj(iunit,4,1,1,4,-999,jarray,anyf,status)
        print *,'ftgcvj values, anyf,status',jarray,anyf,status
        call ftgcvj(iunit,5,1,1,4,-999,jarray,anyf,status)
        print *,'ftgcvj values, anyf,status',jarray,anyf,status

        print *,' '
        print *,'Now do the binary extension...'
        call ftcrhd(iunit,status)
        print *,'Created new HDU: ftcrhd status',status

        nrows=4
        tfield=10
        ttype(1)='Label1'
        ttype(2)='Label2'
        ttype(3)='Label3'
        ttype(4)='Label4'
        ttype(5)='Label5'
        ttype(6)='Label6'
        ttype(7)='Label7'
        ttype(8)='Label8'
        ttype(9)='Label9'
        ttype(10)='Label10'
        tform(1)='8A'
        tform(2)='L'
        tform(3)='X'
        tform(4)='B'
        tform(5)='I'
        tform(6)='J'
        tform(7)='E'
        tform(8)='D'
        tform(9)='C'
        tform(10)='M'

        tunit(1)=' '
        tunit(2)=' '
        tunit(3)='cm'
        tunit(4)='erg/s'
        extnam='Test-Binary'
        pcount=0

        call ftphbn(iunit,nrows,tfield,ttype,tform,tunit,extnam,
     &    pcount,status)
        print *,'Wrote required header: ftpbnh status',status

C       note that the following call is optional
        call fthdef(iunit,0,status)
        print *,'Defined header length: fthdef status',status

        call ftbdef(iunit,tfield,tform,pcount,nrows,status)
        print *,'Defined table structure: ftbdef status',status

C       initialize table values
        carray(1)='STAR'
        carray(2)='GALAXY'
        larray(1)=.true.
        larray(2)=.false.
        iarray(1)=120
        iarray(2)=121
        jarray(1)=1500
        jarray(2)=-1500
        earray(1)=15000.
        earray(2)=-15000.
        darray(1)= 150000.
        darray(2)=-150000.
        comp(1)=(15,1)
        comp(2)=(-15,1)

        print *,'Write first 2 rows of data to table:'
        call ftpcls(iunit,1,1,1,2,carray,status)
        print *,'ftpcls status',status
        call ftpcll(iunit,2,1,1,2,larray,status)
        print *,'ftpcll status',status
        call ftpcli(iunit,4,1,1,2,iarray,status)
        print *,'ftpcli status',status
        call ftpcli(iunit,5,1,1,2,iarray,status)
        print *,'ftpcli status',status
        call ftpclj(iunit,6,1,1,2,jarray,status)
        print *,'ftpclj status',status
        call ftpcle(iunit,7,1,1,2,earray,status)
        print *,'ftpcle status',status
        call ftpcld(iunit,8,1,1,2,darray,status)
        print *,'ftpcld status',status
        call ftpclc(iunit,9,1,1,2,comp,status)
        print *,'ftpclc status',status

        call ftpcls(iunit,1,4,1,1,carray,status)
        call ftpcll(iunit,2,4,1,1,larray,status)
        call ftpcli(iunit,4,4,1,1,iarray,status)
        call ftpcli(iunit,5,4,1,1,iarray,status)
        call ftpclj(iunit,6,4,1,1,jarray,status)
        call ftpcle(iunit,7,4,1,1,earray,status)
        call ftpcld(iunit,8,4,1,1,darray,status)
        call ftpclc(iunit,9,4,1,1,comp,status)
        print *,'Wrote first 4th row of data to table: status=',status

        inulls(1)=13
        inulls(2)=-13
        inulls(3)=-13
        call ftpknj(iunit,'TNULL',4,3,inulls,'Null values&',status)
        print *,'Wrote null values to header: ftpkns:',status


        call fttnul(iunit,4,inulls(1),status)
        call fttnul(iunit,5,inulls(2),status)
        call fttnul(iunit,6,inulls(3),status)
        print *,'Defined null values: ftpkns:',status

        call ftpclu(iunit,1,3,1,1,status)
        call ftpclu(iunit,2,3,1,1,status)
        call ftpclu(iunit,4,3,1,1,status)
        call ftpclu(iunit,5,3,1,1,status)
        call ftpclu(iunit,6,3,1,1,status)
        call ftpclu(iunit,7,3,1,1,status)
        call ftpclu(iunit,8,3,1,1,status)
        call ftpclu(iunit,9,3,1,1,status)
        call ftpclu(iunit,10,3,1,1,status)
        print *,'Set 3rd row undefined: ftpclu status = ',status

C       initialize the arrays to be filled by reading back the table
        carray(1)=' '
        carray(2)=' '
        larray(1)=.false.
        larray(2)=.false.
        iarray(1)=0
        iarray(2)=0
        jarray(1)=0
        jarray(2)=0
        earray(1)=0.
        earray(2)=0.
        darray(1)=0.
        darray(2)=0.
        comp(1)=(0,0)
        comp(2)=(0,0)

        print *,'Read back the data from the table (no conversion)'
        call ftgcvs(iunit,1,1,1,4,'NULL',carray,anyf,status)
        print *,'col 1 ftgcvs values, anyf,status=',carray,anyf,status
        call ftgcl(iunit,2,1,1,4,larray,status)
        print *,'col 2 ftgcl values, status=',larray,status
        ival=-99
        call ftgcvi(iunit,4,1,1,4,ival,iarray,anyf,status)
        print *,'col 4 ftgcvi values, anyf,status',iarray,anyf,status
        call ftgcvi(iunit,5,1,1,4,ival,iarray,anyf,status)
        print *,'col 5 ftgcvi values, anyf,status',iarray,anyf,status
        call ftgcvj(iunit,6,1,1,4,-99,jarray,anyf,status)
        print *,'col 6 ftgcvj values, anyf,status',jarray,anyf,status
        call ftgcve(iunit,7,1,1,4,-99.,earray,anyf,status)
        print *,'col 7 ftgcve values, anyf,status',earray,anyf,status
        dval=-99.
        call ftgcvd(iunit,8,1,1,4,dval,darray,anyf,status)
        print *,'col 8 ftgcvd values, anyf,status',darray,anyf,status
        comval=(-99.,99.)
        call ftgcvc(iunit,9,1,1,4,comval,comp,anyf,status)
        print *,'col 9 ftgcvc values, anyf,status',comp,anyf,status

        print *,'Read back the data from the table (with conversion)'
        dval=-999.
        call ftgcvd(iunit,4,1,1,4,dval,darray,anyf,status)
        print *,'col 4 ftgcvd values, anyf,status',darray,anyf,status
        call ftgcvd(iunit,5,1,1,4,dval,darray,anyf,status)
        print *,'col 5 ftgcvd values, anyf,status',darray,anyf,status
        call ftgcvd(iunit,6,1,1,4,dval,darray,anyf,status)
        print *,'col 6 ftgcvd values, anyf,status',darray,anyf,status
        call ftgcvj(iunit,7,1,1,4,-99,jarray,anyf,status)
        print *,'col 7 ftgcvj values, anyf,status',jarray,anyf,status
        call ftgcvj(iunit,8,1,1,4,-99,jarray,anyf,status)
        print *,'col 8 ftgcvj values, anyf,status',jarray,anyf,status
       
        call ftmahd(iunit,1,htype,status)
        print *,'Moved back to the primary array:'
        print *,'  ftmahd htype,status=',htype,status

        call ftpprj(iunit,group,fpixel,nelem,ivalue,status)
        print *,'Wrote the primary array of data: ftppri status',status

        call ftpkyj(iunit,'NEWKEY',42,
     &   'This keyword added after binary extension',status)
        print *,'Appended a new keyword: ftpkyj status',status

        call ftmrhd(iunit,2,htype,status)
        print *,'Moved forward to the binary table again:'
        print *,'  ftmrhd htype,status=',htype,status

        call ftghsp(iunit,nkeys,nmore,status)
        print *,'Find space left in header: ftghsp:'
        print *,'nkeys,nmore,status',nkeys,nmore,status

        call ftdkey(iunit,'extname',status)
        print *,'Deleted a keyword: ftdkwy status:',status

        call ftclos(iunit,status)
        print *,'Closed FITS file: ftclos status',status

        if (status .le. 0)then
                print *,'*** Program completed successfully ***'
        else
           print *,'*** ERROR - program did not run successfully ***'
        end if

        end
