Convert a subroutine into a program

1

I want to convert the following subroutine extracted from here into a separate program:

subroutine bilbao_read(sgn)

    !!! This subroutine read symmetry operations and 
    !!! character tables from Bilbao.
    !!! Compare the input symmetry operations with Bilbao. 

    integer,          intent(in) :: sgn

    character(len=3)   :: csgn
    character(len=180) :: spgpath, spgfile
    character(len=10)  :: symbol_sg

    real(dp)           :: Df(2,4), abcde(5), ktmp(3), ttmp(1,3)
    real(dp)           :: tmp33(3,3) 

    integer            :: Numk, antiss, tnir, wi 

    integer            :: i, j, itmp, jtmp 
    integer            :: iir, nele, ikt 
    character(len=5)   :: irtmp 
    character(len=2)   :: nametmp, nametmp2 
    character(len=15)  :: ckpoint 
    character(len=40)  :: ListIrrep

    ! bilbao table file
    integer,     parameter   :: bb = 11
    ! output file : operations in conventional basis
    integer,     parameter   :: op = 9
    ! output file : special k points
    integer,     parameter   :: sk = 00


    if     (sgn < 10)  then; write(csgn,'(I1)') sgn
    elseif (sgn < 100) then; write(csgn,'(I2)') sgn
    else                   ; write(csgn,'(I3)') sgn
    endif 

    !spgpath = '/storagehome/jcgao/soft/irvsp/src_irvsp4/src_lib'
#ifdef IRVSPDATA 
    call get_environment_variable('IRVSPDATA',spgpath)
#else
    write(6,*) "Environment variable 'IRVSPDATA' must be provided "
    write(6,*) "Please run the following commands to make the library:"
    write(6,*) "./configure.sh"
    write(6,*) "source ~/.bashrc"
    write(6,*) "make lib"
    stop
#endif 
    spgfile = trim(spgpath)//'/kLittleGroups/kLG_'//trim(csgn)//'.data'
    write(*,*) "SPGFILE :", trim(adjustl(spgfile)) 

    open(unit=bb, file=spgfile, status='old', form='unformatted')
    open(unit=sk, file='SGklist_'//trim(csgn)//'.cht', status='unknown')

    read(bb) num_doub_sym, symbol_sg

    if     (symbol_sg(1:1) == 'P') then
        Kc2p = Pabc
    elseif (symbol_sg(1:1) == 'C') then 
        Kc2p = Cabc
        if (sgn==68) Kc2p = Cabc68
    elseif (symbol_sg(1:1) == 'B') then
        Kc2p = Babc
    elseif (symbol_sg(1:1) == 'A') then
        Kc2p = Aabc
    elseif (symbol_sg(1:1) == 'R') then
        Kc2p = Rabc
    elseif (symbol_sg(1:1) == 'F') then
        Kc2p = Fabc
    elseif (symbol_sg(1:1) == 'I') then
        Kc2p = Iabc
    else
        stop "Error in space-group-symbol"
    endif 
    call invreal33(Kc2p, p2cR)

    rot_bilbao = 0
    tau_bilbao = 0.d0
    SU2_bilbao = 0.d0
    do i = 1, num_doub_sym 
        read(bb) rot_bilbao(:,:,i), tau_bilbao(:,i), Df(:,:)
        SU2_bilbao(1,1,i)=cmplx(Df(1,1)*dcos(PI*Df(2,1)),Df(1,1)*dsin(PI*Df(2,1)),dp)
        SU2_bilbao(1,2,i)=cmplx(Df(1,2)*dcos(PI*Df(2,2)),Df(1,2)*dsin(PI*Df(2,2)),dp)
        SU2_bilbao(2,1,i)=cmplx(Df(1,3)*dcos(PI*Df(2,3)),Df(1,3)*dsin(PI*Df(2,3)),dp)
        SU2_bilbao(2,2,i)=cmplx(Df(1,4)*dcos(PI*Df(2,4)),Df(1,4)*dsin(PI*Df(2,4)),dp)
    enddo 

    ! write operations under conventional basis
    open(unit=op, file='SGoperation_'//trim(csgn)//'.cht', status='unknown')
    write(op,*) symbol_sg 
    write(op, "(' From conv. to prim. reciprocal space  (DB1)')")
    write(op, "(3(3F16.8,/))") Kc2p 
    write(op, "(' From prim. to conv. reciprocal space  (DR1)')")
    write(op, "(3(3F16.8,/))") p2cR
    do i = 1, num_doub_sym 
        write(op,601) i, rot_bilbao(:,1,i), tau_bilbao(1,i)
        write(op,602)    rot_bilbao(:,2,i), tau_bilbao(2,i), SU2_bilbao(1,1,i), SU2_bilbao(1,2,i)
        write(op,602)    rot_bilbao(:,3,i), tau_bilbao(3,i), SU2_bilbao(2,1,i), SU2_bilbao(2,2,i)
    enddo 
    close(op)

    ! conventional cell -> primitive cell
    invrot_bilbao = 0
    do i = 1, num_doub_sym 
        tmp33(:,:) = dble(transpose(rot_bilbao(:,:,i)))
        rot_bilbao(:,:,i) = nint(matmul(matmul(p2cR, tmp33), Kc2p(:,:))) 
        tau_bilbao(:,i) = matmul(p2cR, tau_bilbao(:,i))
        call invmati(rot_bilbao(:,:,i), invrot_bilbao(:,:,i))
    enddo 


    ! read character tables
    nirreps(:)=0
    sirreps(:)=0
    antisym(:)=0
    Herringrule(:,:)=-2

    labels=0
    iir=0;ikt=0
    tableTraces(:,:,:)=cmplx_0 
    chartTraces(:,:,:)=cmplx_0 
    coeff_uvw(:,:,:,:)=cmplx_0
    factsTraces(:,:,:)='            '
    chkpoint(:)='***************'
    nametmp='  '
    read(11)  Numk,tnir

    DO wi=1,tnir
      read(11) ListIrrep
      nametmp2=nametmp
      read(ListIrrep,*) ktmp(:),antiss,irtmp, itmp,itmp,nametmp,jtmp
      IF(nametmp/=nametmp2) THEN 
         IF(ikt>0) THEN
            nirreps(ikt)=iir
           !call dumptableofIrs(ikt,9)
            call Kreal2string(samplek(:,ikt),ckpoint) 
            ttmp(1,1:3)=samplek(1:3,ikt)
            WRITE(99,"(1X,I2,A21,3F6.3,A5,3F8.3,I4,A4)") ikt, samplekname(ikt)//' ('//ckpoint//')' & 
              , samplek(:,ikt),' --> ',matmul(ttmp(:,:),Kc2p(:,:)),ikt,samplekname(ikt)
         ENDIF
        !------out
         ikt=ikt+1; iir=0
         antisym(ikt)=antiss
      ENDIF
!
      samplek(:,ikt)=ktmp(:)
      samplekname(ikt)=nametmp
      iir=iir+1
      nele=0
      irk:DO j=1,num_doub_sym
          read(11) itmp,itmp
          IF(itmp==1) THEN
             nele=nele+1
             labels(1,j,iir,ikt)=itmp
             read(11) itmp;labels(2,j,iir,ikt)=itmp
             abcde(:)=0._dp
             IF(itmp==1) THEN
                read(11) abcde(1:2)
             ELSEIF(itmp==2) THEN
                read(11) abcde(1:5)
                coeff_uvw(:,j,iir,ikt)=abcde(3:5)
                write(factsTraces(j,iir,ikt),"(3F4.1)") abcde(3:5)
             ELSE
                STOP "Error!" 
             ENDIF
                chartTraces(j,iir,ikt)=cmplx(abcde(1)*dcos(PI*abcde(2)) &
                                            ,abcde(1)*dsin(PI*abcde(2)),dp)
          ELSEIF(itmp==0) THEN
          ELSE
           STOP "Error!!" 
          ENDIF
      END DO irk
!
      nelelittle (    ikt) = nele
      Irrepsname (iir,ikt) = irtmp
      Herringrule(iir,ikt) = jtmp
    END DO
    !print*,"tnir=",tnir
!
            nirreps(ikt)=iir
           !call dumptableofIrs(ikt,9)
            call Kreal2string(samplek(:,ikt),ckpoint) 
            ttmp(1,1:3)=samplek(1:3,ikt)
            WRITE(99,"(1X,I2,A21,3F6.3,A5,3F8.3,I4,A4)") ikt, samplekname(ikt)//' ('//ckpoint//')' & 
              , samplek(:,ikt),' --> ',matmul(ttmp(:,:),Kc2p(:,:)),ikt,samplekname(ikt)
    IF(ikt/=Numk) STOP"ERROR in little groups of k-points"
    num_ktype=ikt


 600  format(/,10X,A30)
 601  format(/,3X,'i=',I2,3X,3I2,F8.3)
 602  format(10X,3I2,F8.3,2X,'(',2F6.3,')(',2F6.3,')')

end subroutine bilbao_read

Any hints/tips/comments/suggestions for this conversion?

Regards,
HZ

2

You can do several things:

  • Create a program that simply calls this routine. You will have to supply the right value for sgn.
  • Change the header to “program bilbao_read” and the last statement to “end program bilbao_read” (or even simply “end”). Then you will have to think of a convenient way to set sgn. It could simply be a fixed value - do remove the “intent(in)” though.
3

I want to use it as an argument/parameter of the compiled program instead of a fixed value. How to do it?

4

You can use the get_command_argument routine to retrieve the arguments you pass to the program

5

I see an example here:

6

Well, that is useful to check that one or more arguments were provided ;). But to get the actual argument, you need get_command_argument.

7
  1. In fact, If you open the link above to view the relevant code example, you’ll find that the example shown there calls get_command_argument in it, so I put the link here as a reference.

Here is the slight revised version of the above code snippet:

program echo_command_line
    integer i, cnt, len, status
    ! I change c to a longer string variable:
    character c*100, b*100

    call get_command(b, len, status)
    if (status .ne. 0) then
        write (*,*) 'get_command failed with status = ', status
        stop
    end if
    write (*,*) 'command line = ', b (1:len)

    call get_command_argument (0, c, len, status)
    if (status .ne. 0) then
        write (*,*) 'Getting command name failed with status = ', status
        stop
    end if
    write (*,*) 'command name = ', c (1:len)

    cnt = command_argument_count ()
    write (*,*) 'number of command arguments = ', cnt

    do i = 1, cnt
        call get_command_argument (i, c, len, status)
        if (status .ne. 0) then
            write (*,*) 'get_command_argument failed: status = ', status, ' arg = ', i
            stop
        end if
        write (*,*) 'command arg ', i, ' = ', c (1:len)
    end do

    write (*,*) 'command line processed'
end

See my following testing with the Eclipse Photran plugin:

image
image1668×878 177 KB

  1. I noticed another nice example here:
PROGRAM cmdlnsum
IMPLICIT NONE
CHARACTER(100) :: num1char
CHARACTER(100) :: num2char
REAL :: num1
REAL :: num2
REAL :: numsum

!First, make sure the right number of inputs have been provided
IF(COMMAND_ARGUMENT_COUNT().NE.2)THEN
  WRITE(*,*)'ERROR, TWO COMMAND-LINE ARGUMENTS REQUIRED, STOPPING'
  STOP
ENDIF

CALL GET_COMMAND_ARGUMENT(1,num1char)   !first, read in the two values
CALL GET_COMMAND_ARGUMENT(2,num2char)

READ(num1char,*)num1                    !then, convert them to REALs
READ(num2char,*)num2

numsum=num1+num2                        !sum numbers
WRITE(*,*)numsum                        !write out value

END PROGRAM

See my following testing within CBFortran:

image
image934×598 77.6 KB

image
image1653×644 97.8 KB