src/util/pup_f.f90.sh

   1 #!/bin/bash
   2 #
   3 # Shell script to create the pup_f.f90 file.
   4 #  Used to avoid duplicate copy-and-paste code in pup_f.f90.
   5
   6 cat > pup_f.f90 << END_OF_HEADER
   7 !   DO NOT EDIT THIS FILE, GENERATE IT FROM RUNNING pup_f.f90.sh
   8     module pupmod
   9       implicit none
  10
  11       interface
  12         function fpup_issizing(p)
  13           INTEGER :: p
  14           logical fpup_issizing
  15         end function
  16         function fpup_ispacking(p)
  17           INTEGER :: p
  18           logical fpup_ispacking
  19         end function
  20         function fpup_isunpacking(p)
  21           INTEGER :: p
  22           logical fpup_isunpacking
  23         end function
  24         function fpup_isdeleting(p)
  25           INTEGER :: p
  26           logical fpup_isdeleting
  27         end function
  28         function fpup_isuserlevel(p)
  29           INTEGER :: p
  30           logical fpup_isuserlevel
  31         end function
  32
  33         subroutine fpup_char(p, d)
  34           INTEGER :: p
  35           CHARACTER :: d
  36         end subroutine
  37         subroutine fpup_short(p, d)
  38           INTEGER :: p
  39           INTEGER (KIND=2) :: d
  40         end subroutine
  41         subroutine fpup_int(p, d)
  42           INTEGER :: p
  43           INTEGER (KIND=4) :: d
  44         end subroutine
  45         subroutine fpup_long(p, d)
  46           INTEGER :: p
  47           INTEGER (KIND=8) :: d
  48         end subroutine
  49         subroutine fpup_real(p, d)
  50           INTEGER :: p
  51           REAL (KIND=4)  :: d
  52         end subroutine
  53         subroutine fpup_double(p, d)
  54           INTEGER :: p
  55           REAL (KIND=8)  :: d
  56         end subroutine
  57         subroutine fpup_logical(p, d)
  58           INTEGER :: p
  59           LOGICAL :: d
  60         end subroutine
  61
  62         subroutine fpup_complex(p, d)
  63           INTEGER :: p
  64           COMPLEX*8 :: d
  65         end subroutine
  66
  67         subroutine fpup_doublecomplex(p, d)
  68           INTEGER :: p
  69           COMPLEX*16 :: d
  70         end subroutine
  71
  72       end interface
  73
  74 END_OF_HEADER
  75
  76 for t in chars ints longs reals doubles logicals complexes doublecomplexes
  77 do
  78   echo "      interface fpup_${t}" >> pup_f.f90
  79   if test $t = "chars"
  80   then
  81   echo "       module procedure fpup_${t}_0" >> pup_f.f90
  82   fi
  83   for i in  1 2 3 4 5 6 7
  84   do
  85   echo "       module procedure fpup_${t}_${i}" >> pup_f.f90
  86   done
  87   echo "      end interface fpup_${t}" >> pup_f.f90
  88   echo >> pup_f.f90
  89 done
  90
  91 cat >> pup_f.f90 << END_OF_HEADER
  92       interface pup
  93         module procedure pi,pia1d,pia2d,pia3d,pia4d,pia5d,pia6d,pia7d
  94         module procedure pc,pca1d,pca2d,pca3d,pca4d,pca5d,pca6d,pca7d
  95         module procedure ps,psa1d,psa2d,psa3d,psa4d,psa5d,psa6d,psa7d
  96         module procedure pr,pra1d,pra2d,pra3d,pra4d,pra5d,pra6d,pra7d
  97         module procedure pd,pda1d,pda2d,pda3d,pda4d,pda5d,pda6d,pda7d
  98         module procedure pl,pla1d,pla2d,pla3d,pla4d,pla5d,pla6d,pla7d
  99         module procedure px,pxa1d,pxa2d,pxa3d,pxa4d,pxa5d,pxa6d,pxa7d
 100         module procedure py,pya1d,pya2d,pya3d,pya4d,pya5d,pya6d,pya7d
 101       end interface
 102       interface apup
 103         module procedure apia1d,apia2d,apia3d,apia4d,apia5d,apia6d,apia7d
 104         module procedure apca1d,apca2d,apca3d,apca4d,apca5d,apca6d,apca7d
 105         module procedure apsa1d,apsa2d,apsa3d,apsa4d,apsa5d,apsa6d,apsa7d
 106         module procedure apra1d,apra2d,apra3d,apra4d,apra5d,apra6d,apra7d
 107         module procedure apda1d,apda2d,apda3d,apda4d,apda5d,apda6d,apda7d
 108         module procedure apla1d,apla2d,apla3d,apla4d,apla5d,apla6d,apla7d
 109         module procedure apxa1d,apxa2d,apxa3d,apxa4d,apxa5d,apxa6d,apxa7d
 110         module procedure apya1d,apya2d,apya3d,apya4d,apya5d,apya6d,apya7d
 111
 112       ! NOTE: for compilers with full Fortran2003 support (GNU-4.9+, IC-15.0+, etc.)
 113       ! ... we can provide a single apup interface for both pointers and allocatables
 114       ! ... by simply removing the next two lines.
 115       end interface
 116       interface apup_al
 117         module procedure apia1d_al,apia2d_al,apia3d_al,apia4d_al,apia5d_al,apia6d_al,apia7d_al
 118         module procedure apca1d_al,apca2d_al,apca3d_al,apca4d_al,apca5d_al,apca6d_al,apca7d_al
 119         module procedure apsa1d_al,apsa2d_al,apsa3d_al,apsa4d_al,apsa5d_al,apsa6d_al,apsa7d_al
 120         module procedure apra1d_al,apra2d_al,apra3d_al,apra4d_al,apra5d_al,apra6d_al,apra7d_al
 121         module procedure apda1d_al,apda2d_al,apda3d_al,apda4d_al,apda5d_al,apda6d_al,apda7d_al
 122         module procedure apla1d_al,apla2d_al,apla3d_al,apla4d_al,apla5d_al,apla6d_al,apla7d_al
 123         module procedure apxa1d_al,apxa2d_al,apxa3d_al,apxa4d_al,apxa5d_al,apxa6d_al,apxa7d_al
 124         module procedure apya1d_al,apya2d_al,apya3d_al,apya4d_al,apya5d_al,apya6d_al,apya7d_al
 125       end interface
 126       contains
 127       function pup_issz(p)
 128         INTEGER :: p
 129         logical pup_issz
 130         pup_issz = fpup_issizing(p)
 131       end function
 132       function pup_ispk(p)
 133         INTEGER :: p
 134         logical pup_ispk
 135         pup_ispk = fpup_ispacking(p)
 136       end function
 137       function pup_isupk(p)
 138         INTEGER :: p
 139         logical pup_isupk
 140         pup_isupk = fpup_isunpacking(p)
 141       end function
 142       function pup_isdel(p)
 143         INTEGER :: p
 144         logical pup_isdel
 145         pup_isdel = fpup_isdeleting(p)
 146       end function
 147       function pup_isul(p)
 148         INTEGER :: p
 149         logical pup_isul
 150         pup_isul = fpup_isuserlevel(p)
 151       end function
 152
 153
 154       subroutine fpup_chars_0(p, d, c)
 155         INTEGER :: p
 156         CHARACTER(LEN=*)     d
 157         INTEGER :: c
 158         call fpup_charsg(p, d, c)
 159       end subroutine
 160 END_OF_HEADER
 161
 162 for data in "chars/character" "shorts/integer(kind=2)" "ints/integer(kind=4)" "longs/integer(kind=8)" "reals/real(kind=4)" "doubles/real(kind=8)" "logicals/logical"\
 163        "complexes/complex*8" "doublecomplexes/complex*16"
 164 do
 165  pupname=`echo $data | awk -F/ '{print $1}'`
 166  typename=`echo $data | awk -F/ '{print $2}'`
 167  for i in 1 2 3 4 5 6 7
 168  do
 169   echo "       subroutine fpup_${pupname}_${i}(p, d, c)" >> pup_f.f90
 170   echo "        INTEGER :: p" >> pup_f.f90
 171   echo -n "        ${typename}, intent(inout), dimension(:" >> pup_f.f90
 172   n=1
 173   while [ $n -lt $i ]
 174   do
 175     echo -n ",:" >> pup_f.f90
 176     n=`expr $n + 1`
 177   done
 178   echo ") :: d" >> pup_f.f90
 179   echo "        INTEGER :: c" >> pup_f.f90
 180   echo "        call fpup_${pupname}g(p, d, c)"  >> pup_f.f90
 181   echo "       end subroutine" >> pup_f.f90
 182  done
 183  echo >> pup_f.f90
 184 done
 185
 186 #
 187 # Create pup routines for each data type:
 188 #   The "p" routines just copy the data.
 189 #   The "ap" routines also allocate and free the buffer.
 190 # suffix _al means input is allocatable, otherwise its pointer
 191 #
 192 for data in "int/ints/i/integer" "short/shorts/s/integer(kind=2)" "char/chars/c/character" "real/reals/r/real(kind=4)" "double/doubles/d/real(kind=8)" "logical/logicals/l/logical"\
 193       "complex/complexes/x/complex*8" "doublecomplex/doublecomplexes/y/complex*16"
 194 do
 195           pupname=`echo $data | awk -F/ '{print $1}'`
 196         pupnames=`echo $data | awk -F/ '{print $2}'`
 197         cname=`echo $data | awk -F/ '{print $3}'`
 198         fname=`echo $data | awk -F/ '{print $4}'`
 199         echo "Making pup routines for data type $pupname/$cname/$fname"
 200         cat >> pup_f.f90 << END_OF_DATATYPE
 201
 202
 203       subroutine p${cname}(p, i)
 204         INTEGER :: p
 205         $fname, intent(inout) :: i
 206         call fpup_${pupname}(p, i)
 207       end subroutine
 208
 209       subroutine p${cname}a1d(p, arr)
 210         INTEGER :: p
 211         $fname, intent(inout), dimension(:) :: arr
 212         call fpup_${pupnames}(p, arr, size(arr))
 213       end subroutine
 214       subroutine p${cname}a2d(p, arr)
 215         INTEGER :: p
 216         $fname, intent(inout), dimension(:,:) :: arr
 217         call fpup_${pupnames}(p, arr, size(arr))
 218       end subroutine
 219       subroutine p${cname}a3d(p, arr)
 220         INTEGER :: p
 221         $fname, intent(inout), dimension(:,:,:) :: arr
 222         call fpup_${pupnames}(p, arr, size(arr))
 223       end subroutine
 224       subroutine p${cname}a4d(p, arr)
 225         INTEGER :: p
 226         $fname, intent(inout), dimension(:,:,:,:) :: arr
 227         call fpup_${pupnames}(p, arr, size(arr))
 228       end subroutine
 229       subroutine p${cname}a5d(p, arr)
 230         INTEGER :: p
 231         $fname, intent(inout), dimension(:,:,:,:,:) :: arr
 232         call fpup_${pupnames}(p, arr, size(arr))
 233       end subroutine
 234       subroutine p${cname}a6d(p, arr)
 235         INTEGER :: p
 236         $fname, intent(inout), dimension(:,:,:,:,:,:) :: arr
 237         call fpup_${pupnames}(p, arr, size(arr))
 238       end subroutine
 239       subroutine p${cname}a7d(p, arr)
 240         INTEGER :: p
 241         $fname, intent(inout), dimension(:,:,:,:,:,:,:) :: arr
 242         call fpup_${pupnames}(p, arr, size(arr))
 243       end subroutine
 244
 245 END_OF_DATATYPE
 246 done
 247
 248 for arrkind in "pointer/associated/NULLIFY(arr)/" "allocatable/allocated/ /_al"
 249 do
 250   pointer=`echo $arrkind | awk -F/ '{print $1}'`
 251   associated=`echo $arrkind | awk -F/ '{print $2}'`
 252   NULLIFY=`echo $arrkind | awk -F/ '{print $3}'`
 253   suffix=`echo $arrkind | awk -F/ '{print $4}'`
 254   for data in "int/ints/i/integer" "short/shorts/s/integer(kind=2)" "char/chars/c/character" "real/reals/r/real(kind=4)" "double/doubles/d/real(kind=8)" "logical/logicals/l/logical"\
 255     "complex/complexes/x/complex*8" "doublecomplex/doublecomplexes/y/complex*16"
 256   do
 257           pupname=`echo $data | awk -F/ '{print $1}'`
 258         pupnames=`echo $data | awk -F/ '{print $2}'`
 259         cname=`echo $data | awk -F/ '{print $3}'`
 260         fname=`echo $data | awk -F/ '{print $4}'`
 261         echo "Making pup routines for data type $pupname/$cname/$fname"
 262         cat >> pup_f.f90 << END_OF_DATATYPE
 263
 264       subroutine ap${cname}a1d$suffix(p, arr)
 265         INTEGER :: p
 266         $fname, $pointer, dimension(:) :: arr
 267         integer :: n(1)
 268         IF (fpup_isunpacking(p)) THEN
 269           CALL fpup_ints(p,n,1)
 270           If (n(1) >= 0) THEN
 271             ALLOCATE(arr(n(1)))
 272             call fpup_${pupnames}(p, arr, n(1))
 273           ELSE
 274             $NULLIFY
 275           END If
 276         ELSE ! packing
 277           If ($associated(arr)) THEN
 278             n(1)=SIZE(arr,DIM=1)
 279             CALL fpup_ints(p,n,1)
 280             call fpup_${pupnames}(p, arr, n(1))
 281           ELSE
 282             n(1) = -1
 283             CALL fpup_ints(p,n,1)
 284           End If
 285         END IF
 286         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 287           deallocate(arr)
 288         END IF
 289       end subroutine
 290
 291       subroutine ap${cname}a2d$suffix(p, arr)
 292         INTEGER :: p
 293         $fname, $pointer, dimension(:,:) :: arr
 294         integer :: n(2)
 295         IF (fpup_isunpacking(p)) THEN
 296           CALL fpup_ints(p,n,2)
 297           If (n(1) >= 0) THEN
 298             ALLOCATE(arr(n(1),n(2)))
 299             call fpup_${pupnames}(p, arr, size(arr))
 300           ELSE
 301             $NULLIFY
 302           END If
 303         ELSE ! packing
 304           If ($associated(arr)) THEN
 305             n(1)=SIZE(arr,DIM=1)
 306             n(2)=SIZE(arr,DIM=2)
 307             CALL fpup_ints(p,n,2)
 308             call fpup_${pupnames}(p, arr, size(arr))
 309           ELSE
 310             n(1) = -1
 311             n(2) = -1
 312             CALL fpup_ints(p,n,2)
 313           End If
 314         END IF
 315         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 316           deallocate(arr)
 317         END IF
 318       end subroutine
 319
 320       subroutine ap${cname}a3d$suffix(p, arr)
 321         INTEGER :: p
 322         $fname, $pointer, dimension(:,:,:) :: arr
 323         integer :: n(3)
 324         IF (fpup_isunpacking(p)) THEN
 325           CALL fpup_ints(p,n,3)
 326           If (n(1) >= 0) THEN
 327             ALLOCATE(arr(n(1),n(2),n(3)))
 328             call fpup_${pupnames}(p, arr, size(arr))
 329           ELSE
 330             $NULLIFY
 331           END If
 332         ELSE ! packing
 333           If ($associated(arr)) THEN
 334             n(1)=SIZE(arr,DIM=1)
 335             n(2)=SIZE(arr,DIM=2)
 336             n(3)=SIZE(arr,DIM=3)
 337             CALL fpup_ints(p,n,3)
 338             call fpup_${pupnames}(p, arr, size(arr))
 339           ELSE
 340             n(1) = -1
 341             n(2) = -1
 342             n(3) = -1
 343             CALL fpup_ints(p,n,3)
 344           End If
 345         END IF
 346         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 347           deallocate(arr)
 348         END IF
 349       end subroutine
 350
 351       subroutine ap${cname}a4d$suffix(p, arr)
 352         INTEGER :: p
 353         $fname, $pointer, dimension(:,:,:,:) :: arr
 354         integer :: n(4)
 355         IF (fpup_isunpacking(p)) THEN
 356           CALL fpup_ints(p,n,4)
 357           If (n(1) >= 0) THEN
 358             ALLOCATE(arr(n(1),n(2),n(3),n(4)))
 359             call fpup_${pupnames}(p, arr, size(arr))
 360           ELSE
 361             $NULLIFY
 362           END If
 363         ELSE ! packing
 364           If ($associated(arr)) THEN
 365             n(1)=SIZE(arr,DIM=1)
 366             n(2)=SIZE(arr,DIM=2)
 367             n(3)=SIZE(arr,DIM=3)
 368             n(4)=SIZE(arr,DIM=4)
 369             CALL fpup_ints(p,n,4)
 370             call fpup_${pupnames}(p, arr, size(arr))
 371           ELSE
 372             n(1) = -1
 373             n(2) = -1
 374             n(3) = -1
 375             n(4) = -1
 376             CALL fpup_ints(p,n,4)
 377           End If
 378         END IF
 379         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 380           deallocate(arr)
 381         END IF
 382       end subroutine
 383
 384       subroutine ap${cname}a5d$suffix(p, arr)
 385         INTEGER :: p
 386         $fname, $pointer, dimension(:,:,:,:,:) :: arr
 387         integer :: n(5)
 388         IF (fpup_isunpacking(p)) THEN
 389           CALL fpup_ints(p,n,5)
 390           If (n(1) >= 0) THEN
 391             ALLOCATE(arr(n(1),n(2),n(3),n(4),n(5)))
 392             call fpup_${pupnames}(p, arr, size(arr))
 393           ELSE
 394             $NULLIFY
 395           END If
 396         ELSE ! packing
 397           If ($associated(arr)) THEN
 398             n(1)=SIZE(arr,DIM=1)
 399             n(2)=SIZE(arr,DIM=2)
 400             n(3)=SIZE(arr,DIM=3)
 401             n(4)=SIZE(arr,DIM=4)
 402             n(5)=SIZE(arr,DIM=5)
 403             CALL fpup_ints(p,n,5)
 404             call fpup_${pupnames}(p, arr, size(arr))
 405           ELSE
 406             n(1) = -1
 407             n(2) = -1
 408             n(3) = -1
 409             n(4) = -1
 410             n(5) = -1
 411             CALL fpup_ints(p,n,5)
 412           End If
 413         END IF
 414         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 415           deallocate(arr)
 416         END IF
 417       end subroutine
 418
 419       subroutine ap${cname}a6d$suffix(p, arr)
 420         INTEGER :: p
 421         $fname, $pointer, dimension(:,:,:,:,:,:) :: arr
 422         integer :: n(6)
 423         IF (fpup_isunpacking(p)) THEN
 424           CALL fpup_ints(p,n,6)
 425           If (n(1) >= 0) THEN
 426             ALLOCATE(arr(n(1),n(2),n(3),n(4),n(5),n(6)))
 427             call fpup_${pupnames}(p, arr, size(arr))
 428           ELSE
 429             $NULLIFY
 430           END If
 431         ELSE ! packing
 432           If ($associated(arr)) THEN
 433             n(1)=SIZE(arr,DIM=1)
 434             n(2)=SIZE(arr,DIM=2)
 435             n(3)=SIZE(arr,DIM=3)
 436             n(4)=SIZE(arr,DIM=4)
 437             n(5)=SIZE(arr,DIM=5)
 438             n(6)=SIZE(arr,DIM=6)
 439             CALL fpup_ints(p,n,6)
 440             call fpup_${pupnames}(p, arr, size(arr))
 441           ELSE
 442             n(1) = -1
 443             n(2) = -1
 444             n(3) = -1
 445             n(4) = -1
 446             n(5) = -1
 447             n(6) = -1
 448             CALL fpup_ints(p,n,6)
 449           End If
 450         END IF
 451         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 452           deallocate(arr)
 453         END IF
 454       end subroutine
 455
 456       subroutine ap${cname}a7d$suffix(p, arr)
 457         INTEGER :: p
 458         $fname, $pointer, dimension(:,:,:,:,:,:,:) :: arr
 459         integer :: n(7)
 460         IF (fpup_isunpacking(p)) THEN
 461           CALL fpup_ints(p,n,7)
 462           If (n(1) >= 0) THEN
 463             ALLOCATE(arr(n(1),n(2),n(3),n(4),n(5),n(6),n(7)))
 464             call fpup_${pupnames}(p, arr, size(arr))
 465           ELSE
 466             $NULLIFY
 467           END If
 468         ELSE ! packing
 469           If ($associated(arr)) THEN
 470             n(1)=SIZE(arr,DIM=1)
 471             n(2)=SIZE(arr,DIM=2)
 472             n(3)=SIZE(arr,DIM=3)
 473             n(4)=SIZE(arr,DIM=4)
 474             n(5)=SIZE(arr,DIM=5)
 475             n(6)=SIZE(arr,DIM=6)
 476             n(7)=SIZE(arr,DIM=7)
 477             CALL fpup_ints(p,n,7)
 478             call fpup_${pupnames}(p, arr, size(arr))
 479           ELSE
 480             n(1) = -1
 481             n(2) = -1
 482             n(3) = -1
 483             n(4) = -1
 484             n(5) = -1
 485             n(6) = -1
 486             n(7) = -1
 487             CALL fpup_ints(p,n,7)
 488           End If
 489         END IF
 490         IF (fpup_isdeleting(p) .and. $associated(arr)) THEN
 491           deallocate(arr)
 492         END IF
 493         end subroutine
 494
 495 END_OF_DATATYPE
 496
 497   done
 498 done
 499
 500 echo "    end module" >> pup_f.f90
 501