dk = 1;

ParallelEvaluate[

[Lambda]= 2*10^-1;

 g = 2*10^-1;

[Phi] = 1;

 m = 1;

 f = 7;

lattsize = 50;

p[P_, [Alpha]_, [Beta]_] := {P*Sin[[Alpha]]*Cos[[Beta]], P*Sin[[Alpha]]*Sin[[Beta]], P*Cos[[Alpha]]};

q[Q_, a_] := {Q*Sin[a], 0, Q*Cos[a]};

k[X_] := {0, 0, X};

X = Interpolation[Table[{i, i}, {i, 0, lattsize, 10^-3}]];

[Omega][x_] := Sqrt[x.x + m^2];

(*x:=p, y:=q, z:=k, s:=k+(-)p+(-)q*)

A1[x_, y_, z_, s_] := (1 + (g*[Phi]^2)/(8*[Omega][x]^2))*[Omega][x] + (1 + (g*[Phi]^2)/(8*[Omega][y]^2))*[Omega][y] + (1 + (g*[Phi]^2)/(8*[Omega][z]^2))*[Omega][z] + (1 + (g*[Phi]^2)/(8*[Omega][s]^2))*[Omega][s];

]


ParallelDo[

 solA1 = NSolve[A1[p[P, [Alpha], [Beta]], q[Q, a], k[X[i]], k[X[i]] - p[P, [Alpha], [Beta]] - q[Q, a]] == f, Q, Method -> {Automatic, "SymbolicProcessing" -> 0}];

If[solA1 != {},
    solA1 = Select[Q /. solA1, Positive];
    AppendTo[minA1, {{P, i, [Alpha], [Beta], a}, Min[solA1] /.Infinity -> Null}];
    AppendTo[maxA1, {{P, i, [Alpha], [Beta], a}, Max[solA1] /.-Infinity -> Null}];,

    AppendTo[minA1, {{P, i, [Alpha], [Beta], a}, Null}];
    AppendTo[maxA1, {{P, i, [Alpha], [Beta], a}, Null}];
  ],

  {P, 0, 5, dk}, {i, 0, 10, dk}, {[Alpha], 0, 3, dk}, {[Beta], 0, 6, dk}, {a, 0, 3, dk},
  Method -> "CoarsestGrained"
]

minA1Master = Join @@ ParallelEvaluate[minA1];
maxA1Master = Join @@ ParallelEvaluate[maxA1];